home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
TIPS
/
SWTIP
/
SWTIP
< prev
Wrap
Text File
|
1994-07-02
|
150KB
|
6,058 lines
{!compiler.inc!}
{$A+,B-,D-,E-,F-,G-,I+,L-,N-,O-,R-,S-,V+,X- Borland's Turbo Pascal}
{$ifdef VER70}{$P-,Q-,T+}{$endif}
{$M 65520,0,655360 memory}
{$D+,L+ debugger}
{$B+,R+,S+ run time}{$ifdef VER70}{*$Q+}{$endif}
{!header.p!}
{
Source code from the book
"Software Tools in Pascal", by
Brian W. Kernighan and P.J. Plauger
Addison-Wesley, 1981
ISBN 0-201-10342-7
Copyright (c) 1981
By: Bell Telephone Laboratories, Incorporated, and
Whitesmith's, Ltd.
}
{!copyz.p!}
{ copyz -- copy input to output }
procedure COPYZ;
var
C : CHARACTER;
begin
while (GETC(C) <> ENDFILE) do
PUTC(C)
end;
{!copyprog.pas!}
{ complete copy -- to show one possible implementation }
program COPYPROG(Input, Output);
const
ENDFILE = -1;
NEWLINE = 10; { ASCII value }
type
CHARACTER = -1..127; { ASCII, plus ENDFILE }
{ getc -- get one character from standard input }
function GETC(var C : CHARACTER) : CHARACTER;
var
CH : Char;
begin
if (Eof) then
C := ENDFILE
else if (Eoln) then
begin
ReadLn;
C := NEWLINE;
end
else
begin
Read(CH);
C := Ord(CH);
end;
GETC := C;
end;
{ putc -- put one character on standard output }
procedure PUTC(C : CHARACTER);
begin
if (C = NEWLINE) then
WriteLn
else
Write(Chr(C));
end;
{ copyz -- copy input to output }
procedure COPYZ;
var
C : CHARACTER;
begin
while (GETC(C) <> ENDFILE) do
PUTC(C)
end;
begin { main program }
COPYZ
end.
{!charcnt.p!}
{ charcount -- count characters in standard input }
procedure CHARCOUNT;
var
NC : Integer;
C : CHARACTER;
begin
NC := 0;
while (GETC(C) <> ENDFILE) do
NC := NC+1;
PUTDEC(NC, 1);
PUTC(NEWLINE)
end;
{!linecnt.p!}
{ linecount -- count lines in standard input }
procedure LINECOUNT;
var
N1 : Integer;
C : CHARACTER;
begin
N1 := 0;
while (GETC(C) <> ENDFILE) do
if (C = NEWLINE) then
N1 := N1+1;
PUTDEC(N1, 1);
PUTC(NEWLINE)
end;
{!wordcnt.p!}
{ wordcount -- count words in standard input }
procedure WORDCOUNT;
var
NW : Integer;
C : CHARACTER;
INWORD : Boolean;
begin
NW := 0;
INWORD := False;
while (GETC(C) <> ENDFILE) do
if ((C = BLANK) or
(C = NEWLINE) or
(C = TAB)) then
INWORD := False
else if (not INWORD) then
begin
INWORD := True;
NW := NW+1;
end;
PUTDEC(NW, 1);
PUTC(NEWLINE)
end;
{!detab.p!}
{ detab -- convert tabs to equivalent number of blanks }
procedure DETAB;
const
MAXLINE = 1000; { or whatever }
type
TABTYPE = array[1..MAXLINE] of Boolean;
var
C : CHARACTER;
COL : Integer;
TABSTOPS : TABTYPE;
#include "tabpos.p"
#include "settabs.p"
begin
SETTABS(TABSTOPS); { set initial tab stops }
COL := 1;
while (GETC(C) <> ENDFILE) do
if (C = TAB) then
repeat
PUTC(BLANK);
COL := COL+1
until (TABPOS(COL, TABSTOPS))
else if (C = NEWLINE) then
begin
PUTC(NEWLINE);
COL := 1
end
else
begin
PUTC(C);
COL := COL+1
end
end;
{!tabpos.p!}
{ tabpos -- return true if col is a tab stop }
function TABPOS(COL : Integer;
var TABSTOPS : TABTYPE) : Boolean;
begin
if (COL > MAXLINE) then
TABPOS := True
else
TABPOS := TABSTOPS[COL]
end;
{!settabs.p!}
{ settabs -- set initial tab stops }
procedure SETTABS(var TABSTOPS : TABTYPE);
const
TABSPACE = 8; { 8 spaces per tab }
var
I : Integer;
begin
for I := 1 to MAXLINE do
TABSTOPS[I] := (I mod TABSPACE = 1)
end;
{!entab.p!}
{ entab -- replace blanks by tabs and blanks }
procedure ENTAB;
const
MAXLINE = 1000; { or whatever }
type
TABTYPE = array[1..MAXLINE] of Boolean;
var
C : CHARACTER;
COL, NEWCOL : Integer;
TABSTOPS : TABTYPE;
#include "tabpos.p"
#include "settabs.p"
begin
SETTABS(TABSTOPS);
COL := 1;
repeat
NEWCOL := COL;
while (GETC(C) = BLANK) do { collect blanks }
begin
NEWCOL := NEWCOL+1;
if (TABPOS(NEWCOL, TABSTOPS)) then
begin
PUTC(TAB);
COL := NEWCOL
end
end;
while (COL < NEWCOL) do
begin
PUTC(BLANK); { output leftover blanks }
COL := COL+1
end;
if (C <> ENDFILE) then
begin
PUTC(C);
if (C = NEWLINE) then
COL := 1
else
COL := COL+1
end
until (C = ENDFILE)
end;
{!overstrk.p!}
{ overstrike -- convert backspaces into multiple lines }
procedure OVERSTRIKE;
const
SKIP = BLANK;
NOSKIP = PLUS;
var
C : CHARACTER;
COL, NEWCOL, I : Integer;
begin
COL := 1;
repeat
NEWCOL := COL;
while (GETC(C) = BACKSPACE) do { eat backspaces}
NEWCOL := MAX(NEWCOL-1, 1);
if (NEWCOL < COL) then
begin
PUTC(NEWLINE); { start overstrike line }
PUTC(NOSKIP);
for I := 1 to NEWCOL-1 do
PUTC(BLANK);
COL := NEWCOL
end
else if ((COL = 1) and
(C <> ENDFILE)) then
PUTC(SKIP); { normal line }
{ else middle of line }
if (C <> ENDFILE) then
begin
PUTC(C); { normal character}
if (C = NEWLINE) then
COL := 1
else
COL := COL+1
end
until (C = ENDFILE)
end;
{!max.p!}
{ max -- compute maximum of two integers }
function MAX(X, Y : Integer) : Integer;
begin
if (X > Y) then
MAX := X
else
MAX := Y
end;
{!compress.p!}
{ compress -- compress standard input }
procedure COMPRESS;
const
WARNING = TILDE; { ~ }
var
C, LASTC : CHARACTER;
N : Integer;
#include "putrep.p"
begin
N := 1;
LASTC := GETC(LASTC);
while (LASTC <> ENDFILE) do
begin
if (GETC(C) = ENDFILE) then
begin
if ((N > 1) or
(LASTC = WARNING)) then
PUTREP(N, LASTC)
else
PUTC(LASTC)
end
else if (C = LASTC) then
N := N+1
else if ((N > 1) or
(LASTC = WARNING)) then
begin
PUTREP(N, LASTC);
N := 1
end
else
PUTC(LASTC);
LASTC := C
end
end;
{!putrep.p!}
{ putrep -- put out representation of run of n 'c's }
procedure PUTREP(N : Integer;
C : CHARACTER);
const
MAXREP = 26; { assuming 'A'..'Z' }
THRESH = 4;
begin
while ((N >= THRESH) or
((C = WARNING) and
(N > 0))) do
begin
PUTC(WARNING);
PUTC(MIN(N, MAXREP)-1+Ord('A'));
PUTC(C);
N := N-MAXREP
end;
for N := N downto 1 do
PUTC(C)
end;
{!min.p!}
{ min -- compute minimum of two integers }
function MIN(X, Y : Integer) : Integer;
begin
if (X < Y) then
MIN := X
else
MIN := Y
end;
{!expand.p!}
{ expand -- uncompress standard input }
procedure EXPAND;
const
WARNING = TILDE; { ~ }
var
C : CHARACTER;
N : Integer;
begin
while (GETC(C) <> ENDFILE) do
if (C <> WARNING) then
PUTC(C)
else if (ISUPPER(GETC(C))) then
begin
N := C-Ord('A')+1;
if (GETC(C) <> ENDFILE) then
for N := N downto 1 do
PUTC(C)
else
begin
PUTC(WARNING);
PUTC(N-1+Ord('A'))
end
end
else
begin
PUTC(WARNING);
if (C <> ENDFILE) then
PUTC(C)
end
end;
{!isupper.p!}
{ isupper -- true if c is upper case letter }
function ISUPPER(C : CHARACTER) : Boolean;
begin
ISUPPER := C in [Ord('A') ..Ord('Z')]
end;
{!echo.p!}
{ echo -- echo command line arguments to output }
procedure ECHO;
var
I, J : Integer;
ARGSTR : STRINGZ;
begin
I := 1;
while (GETARG(I, ARGSTR, MAXSTR)) do
begin
if (I > 1) then PUTC(BLANK);
for J := 1 to LENGTHZ(ARGSTR) do
PUTC(ARGSTR[J]);
I := I+1
end;
if (I > 1) then
PUTC(NEWLINE)
end;
{!lengthz.p!}
{ lengthz -- compute the length of stringz }
function LENGTHZ(var S : STRINGZ) : Integer;
var
N : Integer;
begin
N := 1;
while (S[N] <> ENDSTR) do
N := N+1;
LENGTHZ := N-1
end;
{!indexz.p!}
{ indexz -- find position of character c in stringz s }
function INDEXZ(var S : STRINGZ;
C : CHARACTER) : Integer;
var
I : Integer;
begin
I := 1;
while ((S[I] <> C) and
(S[I] <> ENDSTR)) do
I := I+1;
if (S[I] = ENDSTR) then
INDEXZ := 0
else
INDEXZ := I
end;
{!xindex.p!}
{ xindex -- conditionally invert value from index }
function XINDEX(var INSET : STRINGZ;
C : CHARACTER;
ALLBUT : Boolean;
LASTTO : Integer) : Integer;
begin
if (C = ENDFILE) then
XINDEX := 0
else if (not ALLBUT) then
XINDEX := INDEXZ(INSET, C)
else if (INDEXZ(INSET, C) > 0) then
XINDEX := 0
else
XINDEX := LASTTO+1
end;
{!translit.p!}
{ translit -- map characters }
procedure TRANSLIT;
const
NEGATE = CARET; { ^ }
var
ARG, FROMSET, TOSET : STRINGZ;
C : CHARACTER;
I, LASTTO : 0..MAXSTR;
ALLBUT, SQUASH : Boolean;
#include "makeset.p"
#include "xindex.p"
begin
if (not GETARG(1, ARG, MAXSTR)) then
ERROR('usage: translit from to');
ALLBUT := (ARG[1] = NEGATE);
if (ALLBUT) then
I := 2
else
I := 1;
if (not MAKESET(ARG, I, FROMSET, MAXSTR)) then
ERROR('translit: "from" set too large');
if (not GETARG(2, ARG, MAXSTR)) then
TOSET[1] := ENDSTR
else if (not MAKESET(ARG, 1, TOSET, MAXSTR)) then
ERROR('translit: "to" set too large')
else if (LENGTHZ(FROMSET) < LENGTHZ(TOSET)) then
ERROR('translit: "from" shorter than "to"');
LASTTO := LENGTHZ(TOSET);
SQUASH := (LENGTHZ(FROMSET) > LASTTO) or (ALLBUT);
repeat
I := XINDEX(FROMSET, GETC(C), ALLBUT, LASTTO);
if ((SQUASH) and
(I >= LASTTO) and
(LASTTO > 0)) then
begin
PUTC(TOSET[LASTTO]);
repeat
I := XINDEX(FROMSET, GETC(C), ALLBUT, LASTTO)
until (I < LASTTO)
end;
if (C <> ENDFILE) then
begin
if ((I > 0) and
(LASTTO > 0)) then { translate }
PUTC(TOSET[I])
else if (I = 0) then { copy }
PUTC(C)
{ else delete }
end
until (C = ENDFILE)
end;
{!makeset.p!}
{ makeset -- make set from inset[k] in outset }
function MAKESET(var INSET : STRINGZ;
K : Integer;
var OUTSET : STRINGZ;
MAXSET : Integer) : Boolean;
var
J : Integer;
#include "dodash.p"
begin
J := 1;
DODASH(ENDSTR, INSET, K, OUTSET, J, MAXSET);
MAKESET := ADDSTR(ENDSTR, OUTSET, J, MAXSET)
end;
{!addstr.p!}
{ addstr -- put c in outset[j] if it fits, increment j }
function ADDSTR(C : CHARACTER;
var OUTSET : STRINGZ;
var J : Integer;
MAXSET : Integer) : Boolean;
begin
if (J > MAXSET) then
ADDSTR := False
else
begin
OUTSET[J] := C;
J := J+1;
ADDSTR := True
end
end;
{!dodash.p!}
{ dodash -- expand set at src[i] into dest[j], stop at delim }
procedure DODASH(DELIM : CHARACTER;
var SRC : STRINGZ;
var I : Integer;
var DEST : STRINGZ;
var J : Integer;
MAXSET : Integer);
const
ESCAPE = ATSIGN;
var
K : Integer;
JUNK : Boolean;
begin
while ((SRC[I] <> DELIM) and
(SRC[I] <> ENDSTR)) do
begin
if (SRC[I] = ESCAPE) then
JUNK := ADDSTR(ESC(SRC, I), DEST, J, MAXSET)
else if (SRC[I] <> DASH) then
JUNK := ADDSTR(SRC[I], DEST, J, MAXSET)
else if ((J <= 1) or
(SRC[I+1] = ENDSTR)) then
JUNK := ADDSTR(DASH, DEST, J, MAXSET) { literal - }
else if ((ISALPHANUM(SRC[I-1])) and
(ISALPHANUM(SRC[I+1])) and
(SRC[I-1] <= SRC[I+1])) then
begin
for K := SRC[I-1]+1 to SRC[I+1] do
JUNK := ADDSTR(K, DEST, J, MAXSET);
I := I+1
end
else
JUNK := ADDSTR(DASH, DEST, J, MAXSET);
I := I+1
end
end;
{!isalnum.p!}
{ isalphanum -- true if c is letter or digit }
function ISALPHANUM(C : CHARACTER) : Boolean;
begin
ISALPHANUM := C in [Ord('a') ..Ord('z'),
Ord('A') ..Ord('Z'),
Ord('0') ..Ord('9')]
end;
{!esc.p!}
{ esc -- map s[i] into escaped character, increment i }
function ESC(var S : STRINGZ;
var I : Integer) : CHARACTER;
const
ESCAPE = ATSIGN; { @ }
begin
if (S[I] <> ESCAPE) then
ESC := S[I]
else if (S[I+1] = ENDSTR) then { @ not special at end }
ESC := ESCAPE
else
begin
I := I+1;
if (S[I] = Ord('n')) then
ESC := NEWLINE
else if (S[I] = Ord('t')) then
ESC := TAB
else
ESC := S[I]
end
end;
{!putdec.p!}
{ putdec -- put decimal integer n in field width >= w }
procedure PUTDEC(N, W : Integer);
var
I, ND : Integer;
S : STRINGZ;
begin
ND := ITOC(N, S, 1);
for I := ND to W do
PUTC(BLANK);
for I := 1 to ND-1 do
PUTC(S[I])
end;
{!itoc.p!}
{ itoc -- convert integer n to char stringz in s[i]... }
function ITOC(N : Integer;
var S : STRINGZ;
I : Integer) : Integer; { returns end of s }
begin
if (N < 0) then
begin
S[I] := Ord('-');
ITOC := ITOC(-N, S, I+1)
end
else
begin
if (N >= 10) then
I := ITOC(N div 10, S, I);
S[I] := N mod 10+Ord('0');
S[I+1] := ENDSTR;
ITOC := I+1
end
end;
{!ctoi.p!}
{ ctoi -- convert stringz at s[i] to integer, increment i }
function CTOI(var S : STRINGZ;
var I : Integer) : Integer;
var
N, SIGN : Integer;
begin
while ((S[I] = BLANK) or
(S[I] = TAB)) do
I := I+1;
if (S[I] = MINUS) then
SIGN := -1
else
SIGN := 1;
if ((S[I] = PLUS) or
(S[I] = MINUS)) then
I := I+1;
N := 0;
while (ISDIGIT(S[I])) do
begin
N := 10*N+S[I]-Ord('0');
I := I+1
end;
CTOI := SIGN*N
end;
{!isdigit.p!}
{ isdigit -- true if c is a digit }
function ISDIGIT(C : CHARACTER) : Boolean;
begin
ISDIGIT := C in [Ord('0') ..Ord('9')]
end;
{!equal.p!}
{ equal -- test two stringzs for equality }
function EQUAL(var STR1, STR2 : STRINGZ) : Boolean;
var
I : Integer;
begin
I := 1;
while ((STR1[I] = STR2[I]) and
(STR1[I] <> ENDSTR)) do
I := I+1;
EQUAL := (STR1[I] = STR2[I])
end;
{!compare1.p!}
{ compare1 -- (simple version) compare two files for equality }
procedure COMPARE1;
var
LINE1, LINE2 : STRINGZ;
LINENO : Integer;
F1, F2 : Boolean;
#include "diffmsg.p"
begin
LINENO := 0;
repeat
LINENO := LINENO+1;
F1 := GETLINE(LINE1, INFILE1, MAXSTR);
F2 := GETLINE(LINE2, INFILE2, MAXSTR);
if (F1 and F2) then
if (not EQUAL(LINE1, LINE2)) then
DIFFMSG(LINENO, LINE1, LINE2)
until ((F1 = False) or
(F2 = False));
if (F2 and not F1) then
WriteLn('compare: end of file on file1')
else if (F1 and not F2) then
WriteLn('compare: end of file on file2')
end;
{!diffmsg.p!}
{ diffmsg -- print line numbers and differing lines }
procedure DIFFMSG(N : Integer;
var LINE1, LINE2 : STRINGZ);
begin
PUTDEC(N, 1);
PUTC(COLON);
PUTC(NEWLINE);
PUTSTR(LINE1, STDOUT);
PUTSTR(LINE2, STDOUT)
end;
{!compare.p!}
{ compare -- compare two files for equality }
procedure COMPARE;
var
LINE1, LINE2 : STRINGZ;
ARG1, ARG2 : STRINGZ;
LINENO : Integer;
INFILE1, INFILE2 : FILEDESC;
F1, F2 : Boolean;
#include "diffmsg.p"
begin
if ((not GETARG(1, ARG1, MAXSTR)) or
(not GETARG(2, ARG2, MAXSTR))) then
ERROR('usage: compare file1 file2');
INFILE1 := MUSTOPEN(ARG1, IOREAD);
INFILE2 := MUSTOPEN(ARG2, IOREAD);
LINENO := 0;
repeat
LINENO := LINENO+1;
F1 := GETLINE(LINE1, INFILE1, MAXSTR);
F2 := GETLINE(LINE2, INFILE2, MAXSTR);
if (F1 and F2) then
if (not EQUAL(LINE1, LINE2)) then
DIFFMSG(LINENO, LINE1, LINE2)
until ((F1 = False) or
(F2 = False));
if (F2 and not F1) then
WriteLn('compare: end of file on file1')
else if (F1 and not F2) then
WriteLn('compare: end of file on file2')
end;
{!mustopen.p!}
{ mustopen -- open file or die }
function MUSTOPEN(var NAME : STRINGZ;
MODE : Integer) : FILEDESC;
var
FD : FILEDESC;
begin
FD := OPEN(NAME, MODE);
if (FD = IOERROR) then
begin
PUTSTR(NAME, STDERR);
ERROR(': can''t open file')
end;
MUSTOPEN := FD
end;
{!getword.p!}
{ getword -- get word from s[i] into out }
function GETWORD(var S : STRINGZ;
I : Integer;
var OUT : STRINGZ) : Integer;
var
J : Integer;
begin
while (S[I] in [BLANK, TAB, NEWLINE]) do
I := I+1;
J := 1;
while (not(S[I] in [ENDSTR, BLANK, TAB, NEWLINE])) do
begin
OUT[J] := S[I];
I := I+1;
J := J+1
end;
OUT[J] := ENDSTR;
if (S[I] = ENDSTR) then
GETWORD := 0
else
GETWORD := I
end;
{!includez.p!}
{ includez -- replace #include "file" by contents of file }
procedure INCLUDEZ;
var
INCL : STRINGZ; { value is '#include' }
#include "finclude.p"
begin
{ setstring(incl, '#include'); }
INCL[1] := Ord('#');
INCL[2] := Ord('i');
INCL[3] := Ord('n');
INCL[4] := Ord('c');
INCL[5] := Ord('l');
INCL[6] := Ord('u');
INCL[7] := Ord('d');
INCL[8] := Ord('e');
INCL[9] := ENDSTR;
FINCLUDE(STDIN)
end;
{!finclude.p!}
{ finclude -- include file desc f }
procedure FINCLUDE(F : FILEDESC);
var
LINE, STRZ : STRINGZ;
LOC, I : Integer;
F1 : FILEDESC;
#include "getword.p"
begin
while (GETLINE(LINE, F, MAXSTR)) do
begin
LOC := GETWORD(LINE, 1, STRZ);
if (not EQUAL(STRZ, INCL)) then
PUTSTR(LINE, STDOUT)
else
begin
LOC := GETWORD(LINE, LOC, STRZ);
STRZ[LENGTHZ(STRZ)] := ENDSTR; { remove quotes }
for I := 1 to LENGTHZ(STRZ) do
STRZ[I] := STRZ[I+1];
F1 := MUSTOPEN(STRZ, IOREAD);
FINCLUDE(F1);
CLOSEZ(F1)
end
end
end;
{!concatz.p!}
{ concatz -- concatenate files into standard output }
procedure CONCATZ;
var
I : Integer;
JUNK : Boolean;
FD : FILEDESC;
S : STRINGZ;
begin
for I := 1 to NARGS do
begin
JUNK := GETARG(I, S, MAXSTR);
FD := MUSTOPEN(S, IOREAD);
FCOPY(FD, STDOUT);
CLOSEZ(FD)
end
end;
{!fcopy.p!}
{ fcopy -- copy file fin to file fout }
procedure FCOPY(FIN, FOUT : FILEDESC);
var
C : CHARACTER;
begin
while (GETCF(C, FIN) <> ENDFILE) do
PUTCF(C, FOUT)
end;
{!print1.p!}
{ print1 -- print files with headings }
procedure PRINT1;
var
NAME : STRINGZ;
I : Integer;
FIN : FILEDESC;
JUNK : Boolean;
#include "fprint.p"
begin
for I := 1 to NARGS do
begin
JUNK := GETARG(I, NAME, MAXSTR);
FIN := MUSTOPEN(NAME, IOREAD);
FPRINT(NAME, FIN);
CLOSEZ(FIN)
end
end;
{!fprint.p!}
{ fprint -- print file "name" from fin }
procedure FPRINT(var NAME : STRINGZ;
FIN : FILEDESC);
const
MARGIN1 = 2;
MARGIN2 = 2;
BOTTOM = 64;
PAGELEN = 66;
var
LINE : STRINGZ;
LINENO, PAGENO : Integer;
#include "skip.p"
#include "head.p"
begin
PAGENO := 1;
SKIP(MARGIN1);
HEAD(NAME, PAGENO);
SKIP(MARGIN2);
LINENO := MARGIN1+MARGIN2+1;
while (GETLINE(LINE, FIN, MAXSTR)) do
begin
if (LINENO = 0) then
begin
SKIP(MARGIN1);
PAGENO := PAGENO+1;
HEAD(NAME, PAGENO);
SKIP(MARGIN2);
LINENO := MARGIN1+MARGIN2+1
end;
PUTSTR(LINE, STDOUT);
LINENO := LINENO+1;
if (LINENO >= BOTTOM) then
begin
SKIP(PAGELEN-LINENO);
LINENO := 0
end
end;
if (LINENO > 0) then
SKIP(PAGELEN-LINENO)
end;
{!skip.p!}
{ skip -- output n blank lines }
procedure SKIP(N : Integer);
var
I : Integer;
begin
for I := 1 to N do
PUTC(NEWLINE)
end;
{!head.p!}
{ head -- print top of page header }
procedure HEAD(var NAME : STRINGZ;
PAGENO : Integer);
var
PAGE : STRINGZ; { set to ' Page ' }
begin
{ setstring(page, ' Page '); }
PAGE[1] := Ord(' ');
PAGE[2] := Ord('P');
PAGE[3] := Ord('a');
PAGE[4] := Ord('g');
PAGE[5] := Ord('e');
PAGE[6] := Ord(' ');
PAGE[7] := ENDSTR;
PUTSTR(NAME, STDOUT);
PUTSTR(PAGE, STDOUT);
PUTDEC(PAGENO, 1);
PUTC(NEWLINE)
end;
{!print.p!}
{ print -- (default input STDIN) print files with headings }
procedure PRINT;
var
NAME : STRINGZ;
NULL : STRINGZ; { value '' }
I : Integer;
FIN : FILEDESC;
JUNK : Boolean;
#include "fprint.p"
begin
{ setstring (null, ''); }
NULL[1] := ENDSTR;
if (NARGS = 0) then
FPRINT(NULL, STDIN)
else
for I := 1 to NARGS do
begin
JUNK := GETARG(I, NAME, MAXSTR);
FIN := MUSTOPEN(NAME, IOREAD);
FPRINT(NAME, FIN);
CLOSEZ(FIN)
end
end;
{!makecopy.p!}
{ makecopy -- copy one file to another }
procedure MAKECOPY;
var
INNAME, OUTNAME : STRINGZ;
FIN, FOUT : FILEDESC;
begin
if ((not GETARG(1, INNAME, MAXSTR)) or
(not GETARG(2, OUTNAME, MAXSTR))) then
ERROR('usage: makecopy old new');
FIN := MUSTOPEN(INNAME, IOREAD);
FOUT := MUSTCREATE(OUTNAME, IOWRITE);
FCOPY(FIN, FOUT);
CLOSEZ(FIN);
CLOSEZ(FOUT)
end;
{!mustcrea.p!}
{ mustcreate -- create file or die }
function MUSTCREATE(var NAME : STRINGZ;
MODE : Integer) : FILEDESC;
var
FD : FILEDESC;
begin
FD := CREATE(NAME, MODE);
if (FD = IOERROR) then
begin
PUTSTR(NAME, STDERR);
ERROR(': can''t create file')
end;
MUSTCREATE := FD
end;
{!help.p!}
{ help -- print diagnostic for archive }
procedure HELP;
begin
ERROR('usage: archive -[cdptux] archname [files...]')
end;
{!getfns.p!}
{ getfns -- get filenames into fname, look for duplicates }
procedure GETFNS;
var
I, J : Integer;
JUNK : Boolean;
begin
ERRCOUNT := 0;
NFILES := NARGS-2;
if (NFILES > MAXFILES) then
ERROR('archive: too many file names');
for I := 1 to NFILES do
JUNK := GETARG(I+2, FNAME[I], MAXSTR);
for I := 1 to NFILES do
FSTAT[I] := False;
for I := 1 to NFILES-1 do
for J := I+1 to NFILES do
if (EQUAL(FNAME[I], FNAME[J])) then
begin
PUTSTR(FNAME[I], STDERR);
ERROR(': duplicate file name')
end
end;
{!update.p!}
{ update -- update existing files, add new ones at end }
procedure UPDATE(var ANAME : STRINGZ;
CMD : CHARACTER);
var
I : Integer;
AFD, TFD : FILEDESC;
begin
TFD := MUSTCREATE(ARCHTEMP, IOWRITE);
if (CMD = Ord('u')) then
begin
AFD := MUSTOPEN(ANAME, IOREAD);
REPLACE(AFD, TFD, Ord('u')); { update existing }
CLOSEZ(AFD)
end;
for I := 1 to NFILES do
if (FSTAT[I] = False) then
begin
ADDFILE(FNAME[I], TFD);
FSTAT[I] := True
end;
CLOSEZ(TFD);
if (ERRCOUNT = 0) then
FMOVE(ARCHTEMP, ANAME)
else
WriteLn('fatal errors - archive not altered');
REMOVE(ARCHTEMP)
end;
{!fmove.p!}
{ fmove -- move file name1 to name2 }
procedure FMOVE(var NAME1, NAME2 : STRINGZ);
var
FD1, FD2 : FILEDESC;
begin
FD1 := MUSTOPEN(NAME1, IOREAD);
FD2 := MUSTCREATE(NAME2, IOWRITE);
FCOPY(FD1, FD2);
CLOSEZ(FD1);
CLOSEZ(FD2);
end;
{!addfile.p!}
{ addfile -- add file "name" to archive }
procedure ADDFILE(var NAME : STRINGZ;
FD : FILEDESC);
var
HEAD : STRINGZ;
NFD : FILEDESC;
#include "makehdr.p"
begin
NFD := OPEN(NAME, IOREAD);
if (NFD = IOERROR) then
begin
PUTSTR(NAME, STDERR);
MESSAGE(': can''t add');
ERRCOUNT := ERRCOUNT+1
end;
if (ERRCOUNT = 0) then
begin
MAKEHDR(NAME, HEAD);
PUTSTR(HEAD, FD);
FCOPY(NFD, FD);
CLOSEZ(NFD)
end
end;
{!makehdr.p!}
{ makehdr -- make header line for archive member }
procedure MAKEHDR(var NAME, HEAD : STRINGZ);
var
I : Integer;
begin
SCOPY(ARCHHDR, 1, HEAD, 1);
I := LENGTHZ(HEAD)+1;
HEAD[I] := BLANK;
SCOPY(NAME, 1, HEAD, I+1);
I := LENGTHZ(HEAD)+1;
HEAD[I] := BLANK;
I := ITOC(FSIZE(NAME), HEAD, I+1);
HEAD[I] := NEWLINE;
HEAD[I+1] := ENDSTR
end;
{!scopy.p!}
{ scopy -- copy string at src[i] to dest[j] }
procedure SCOPY(var SRC : STRINGZ;
I : Integer;
var DEST : STRINGZ;
J : Integer);
begin
while (SRC[I] <> ENDSTR) do
begin
DEST[J] := SRC[I];
I := I+1;
J := J+1
end;
DEST[J] := ENDSTR;
end;
{!fsize.p!}
{ fsize -- size of file in characters }
function FSIZE(var NAME : STRINGZ) : Integer;
var
C : CHARACTER;
FD : FILEDESC;
N : Integer;
begin
N := 0;
FD := MUSTOPEN(NAME, IOREAD);
while (GETCF(C, FD) <> ENDFILE) do
N := N+1;
CLOSEZ(FD);
FSIZE := N
end;
{!table.p!}
{ table -- print table of archive contents }
procedure TABLE(var ANAME : STRINGZ);
var
HEAD, NAME : STRINGZ;
SIZE : Integer;
AFD : FILEDESC;
#include "tprint.p"
begin
AFD := MUSTOPEN(ANAME, IOREAD);
while (GETHDR(AFD, HEAD, NAME, SIZE)) do
begin
if (FILEARG(NAME)) then
TPRINT(HEAD);
FSKIP(AFD, SIZE)
end;
NOTFOUND
end;
{!tprint.p!}
{ tprint -- print table entry for one member }
procedure TPRINT(var BUF : STRINGZ);
var
I : Integer;
TEMP : STRINGZ;
begin
I := GETWORD(BUF, 1, TEMP); { header }
I := GETWORD(BUF, I, TEMP); { name }
PUTSTR(TEMP, STDOUT);
PUTC(BLANK);
I := GETWORD(BUF, I, TEMP); { size }
PUTSTR(TEMP, STDOUT);
PUTC(NEWLINE)
end;
{!gethdr.p!}
{ gethdr -- get header info from fd }
function GETHDR(FD : FILEDESC;
var BUF, NAME : STRINGZ;
var SIZE : Integer) : Boolean;
var
TEMP : STRINGZ;
I : Integer;
begin
if (GETLINE(BUF, FD, MAXSTR) = False) then
GETHDR := False
else
begin
I := GETWORD(BUF, 1, TEMP);
if (not EQUAL(TEMP, ARCHHDR)) then
ERROR('archive not in proper format');
I := GETWORD(BUF, I, NAME);
SIZE := CTOI(BUF, I);
GETHDR := True
end
end;
{!fskip.p!}
{ fskip -- skip n characters on file fd }
procedure FSKIP(FD : FILEDESC;
N : Integer);
var
C : CHARACTER;
I : Integer;
begin
for I := 1 to N do
if (GETCF(C, FD) = ENDFILE) then
ERROR('archive: end of file in fskip')
end;
{!filearg.p!}
{ filearg -- check if name matches argument list }
function FILEARG(var NAME : STRINGZ) : Boolean;
var
I : Integer;
FOUND : Boolean;
begin
if (NFILES <= 0) then
FILEARG := True
else
begin
FOUND := False;
I := 1;
while ((not FOUND) and
(I <= NFILES)) do
begin
if (EQUAL(NAME, FNAME[I])) then
begin
FSTAT[I] := True;
FOUND := True
end;
I := I+1
end;
FILEARG := FOUND
end
end;
{!notfound.p!}
{ notfound -- print "not found" warning }
procedure NOTFOUND;
var
I : Integer;
begin
for I := 1 to NFILES do
if (FSTAT[I] = False) then
begin
PUTSTR(FNAME[I], STDERR);
WriteLn(': not in archive');
ERRCOUNT := ERRCOUNT+1
end
end;
{!extract.p!}
{ extract -- extract files from archive }
procedure EXTRACT(var ANAME : STRINGZ;
CMD : CHARACTER);
var
ENAME, INLINEZ : STRINGZ;
AFD, EFD : FILEDESC;
SIZE : Integer;
begin
AFD := MUSTOPEN(ANAME, IOREAD);
if (CMD = Ord('p')) then
EFD := STDOUT
else { cmd is 'x' }
EFD := IOERROR;
while (GETHDR(AFD, INLINEZ, ENAME, SIZE)) do
if (not FILEARG(ENAME)) then
FSKIP(AFD, SIZE)
else
begin
if (EFD <> STDOUT) then
EFD := CREATE(ENAME, IOWRITE);
if (EFD = IOERROR) then
begin
PUTSTR(ENAME, STDERR);
WriteLn(': cant''t create');
ERRCOUNT := ERRCOUNT+1;
FSKIP(AFD, SIZE)
end
else
begin
ACOPY(AFD, EFD, SIZE);
if (EFD <> STDOUT) then
CLOSEZ(EFD)
end
end;
NOTFOUND
end;
{!acopy.p!}
{ acopy -- copy n characters from fdi to fdo }
procedure ACOPY(FDI, FDO : FILEDESC;
N : Integer);
var
C : CHARACTER;
I : Integer;
begin
for I := 1 to N do
if (GETCF(C, FDI) = ENDFILE) then
ERROR('archive: end of file in acopy')
else
PUTCF(C, FDO)
end;
{!deletez.p!}
{ deletez -- delete files from archive }
procedure DELETEZ(var ANAME : STRINGZ);
var
AFD, TFD : FILEDESC;
begin
if (NFILES <= 0) then { protect innocents }
ERROR('archive: -d requires explicit file names');
AFD := MUSTOPEN(ANAME, IOREAD);
TFD := MUSTCREATE(ARCHTEMP, IOWRITE);
REPLACE(AFD, TFD, Ord('d'));
NOTFOUND;
CLOSEZ(AFD);
CLOSEZ(TFD);
if (ERRCOUNT = 0) then
FMOVE(ARCHTEMP, ANAME)
else
WriteLn('fatal errors - archive not altered');
REMOVE(ARCHTEMP)
end;
{!replace.p!}
{ replace -- replace or delete files }
procedure REPLACE(AFD, TFD : FILEDESC;
CMD : Integer);
var
INLINEZ, UNAME : STRINGZ;
SIZE : Integer;
begin
while (GETHDR(AFD, INLINEZ, UNAME, SIZE)) do
if (FILEARG(UNAME)) then
begin
if (CMD = Ord('u')) then { add new one }
ADDFILE(UNAME, TFD);
FSKIP(AFD, SIZE) { discard old one }
end
else
begin
PUTSTR(INLINEZ, TFD);
ACOPY(AFD, TFD, SIZE)
end
end;
{!archive.p!}
{ archive -- file maintainer }
procedure Archive;
const
MAXFILES = 100; { or whatever }
var
ANAME : STRINGZ; { archive name }
CMD : STRINGZ; { command type }
FNAME : array[1..MAXFILES] of STRINGZ; { filename args }
FSTAT : array[1..MAXFILES] of Boolean; { true=in archive }
NFILES : Integer; { number of filename arguments }
ERRCOUNT : Integer; { number of errors }
ARCHTEMP : STRINGZ; { temp file name 'artemp' }
ARCHHDR : STRINGZ; { header string '-h-' }
#include "archproc.p"
begin
INITARCH;
if ((not GETARG(1, CMD, MAXSTR)) or
(not GETARG(2, ANAME, MAXSTR))) then
HELP;
GETFNS;
if ((LENGTHZ(CMD) <> 2) or
(CMD[1] <> Ord('-'))) then
HELP
else if ((CMD[2] = Ord('c')) or
(CMD[2] = Ord('u'))) then
UPDATE(ANAME, CMD[2])
else if (CMD[2] = Ord('t')) then
TABLE(ANAME)
else if ((CMD[2] = Ord('x')) or
(CMD[2] = Ord('p'))) then
EXTRACT(ANAME, CMD[2])
else if (CMD[2] = Ord('d')) then
DELETEZ(ANAME)
else
HELP
end;
{!initarch.p!}
{ initarch -- initialize variables for archive }
procedure INITARCH;
begin
{ setstring (archtemp, 'artemp'); }
ARCHTEMP[1] := Ord('a');
ARCHTEMP[2] := Ord('r');
ARCHTEMP[3] := Ord('t');
ARCHTEMP[4] := Ord('e');
ARCHTEMP[5] := Ord('m');
ARCHTEMP[6] := Ord('p');
ARCHTEMP[7] := ENDSTR;
{ setstring(archhdr, '-h-'); }
ARCHHDR[1] := Ord('-');
ARCHHDR[2] := Ord('h');
ARCHHDR[3] := Ord('-');
ARCHHDR[4] := ENDSTR;
end;
{!archproc.p!}
#include "getword.p"
#include "gethdr.p"
#include "filearg.p"
#include "fskip.p"
#include "fmove.p"
#include "fsize.p"
#include "acopy.p"
#include "notfound.p"
#include "addfile.p"
#include "replace.p"
#include "help.p"
#include "getfns.p"
#include "update.p"
#include "table.p"
#include "extract.p"
#include "deletez.p"
#include "initarch.p"
{!bubble.p!}
{ bubble -- bubble sort v[1] ... v[n] increasing }
procedure BUBBLE(var V : INTARRAY;
N : Integer);
var
I, J, K : Integer;
begin
for I := N downto 2 do
for J := 1 to I-1 do
if (V[J] > V[J+1]) then { compare}
begin
K := V[J]; { exchange }
V[J] := V[J+1];
V[J+1] := K
end
end;
{!shell1.p!}
{ shell -- Shell sort v[1]...v[n] increasing }
procedure SHELL(var V : INTARRAY;
N : Integer);
var
GAP, I, J, JG, K : Integer;
begin
GAP := N div 2;
while (GAP > 0) do
begin
for I := GAP+1 to N do
begin
J := I-GAP;
while (J > 0) do
begin
JG := J+GAP;
if (V[J] <= V[JG]) then { compare }
J := 0 { force loop termination }
else
begin
K := V[J]; { exchange }
V[J] := V[JG];
V[JG] := K
end;
J := J-GAP
end
end;
GAP := GAP div 2
end
end;
{!sort1.p!}
{ sort -- external sort of text lines }
procedure INMEMSORT;
const
MAXCHARS = 10000; { maximum # of text characters }
MAXLINES = 300; { maximum # of lines }
type
CHARBUF = array[1..MAXCHARS] of CHARACTER;
CHARPOS = 1..MAXCHARS;
POSBUF = array[1..MAXLINES] of CHARPOS;
POSZ = 0..MAXLINES;
var
LINEBUF : CHARBUF;
LINEPOS : POSBUF;
NLINES : POSZ;
#include "gtext.p"
#include "shell.p"
#include "ptext.p"
begin
if (GTEXT(LINEPOS, NLINES, LINEBUF, STDIN)) then
begin
SHELL(LINEPOS, NLINES, LINEBUF);
PTEXT(LINEPOS, NLINES, LINEBUF, STDOUT)
end
else
ERROR('sort: input too big to sort')
end;
{!gtext.p!}
{ gtext -- get text lines into linebuf }
function GTEXT(var LINEPOS : POSBUF;
var NLINES : POSZ;
var LINEBUF : CHARBUF;
INFILE : FILEDESC) : Boolean;
var
I, LEN, NEXTPOS : Integer;
TEMP : STRINGZ;
DONE : Boolean;
begin
NLINES := 0;
NEXTPOS := 1;
repeat
DONE := (GETLINE(TEMP, INFILE, MAXSTR) = False);
if (not DONE) then
begin
NLINES := NLINES+1;
LINEPOS[NLINES] := NEXTPOS;
LEN := LENGTHZ(TEMP);
for I := 1 to LEN do
LINEBUF[NEXTPOS+I-1] := TEMP[I];
LINEBUF[NEXTPOS+LEN] := ENDSTR;
NEXTPOS := NEXTPOS+LEN+1 { 1 for ENDSTR }
end
until ((DONE) or
(NEXTPOS >= MAXCHARS-MAXSTR) or
(NLINES >= MAXLINES));
GTEXT := DONE
end;
{!ptext.p!}
{ ptext -- output text lines from linebuf }
procedure PTEXT(var LINEPOS : POSBUF;
NLINES : Integer;
var LINEBUF : CHARBUF;
OUTFILE : FILEDESC);
var
I, J : Integer;
begin
for I := 1 to NLINES do
begin
J := LINEPOS[I];
while (LINEBUF[J] <> ENDSTR) do
begin
PUTCF(LINEBUF[J], OUTFILE);
J := J+1
end
end
end;
{!shell.p!}
{ shell -- ascending Shell sort for lines }
procedure SHELL(var LINEPOS : POSBUF;
NLINES : Integer;
var LINEBUF : CHARBUF);
var
GAP, I, J, JG : Integer;
#include "cmp.p"
#include "exchange.p"
begin
GAP := NLINES div 2;
while (GAP > 0) do
begin
for I := GAP+1 to NLINES do
begin
J := I-GAP;
while (J > 0) do
begin
JG := J+GAP;
if (CMP(LINEPOS[J], LINEPOS[JG], LINEBUF) <= 0) then
J := 0 { force loop termination }
else
begin
EXCHANGE(LINEPOS[J], LINEPOS[JG]);
end;
J := J-GAP
end
end;
GAP := GAP div 2
end
end;
{!exchange.p!}
{ exchange -- exchange linebuf[lp1] with linebuf[lp2] }
procedure EXCHANGE(var LP1, LP2 : CHARPOS);
var
TEMP : CHARPOS;
begin
TEMP := LP1;
LP1 := LP2;
LP2 := TEMP
end;
{!cmp.p!}
{ cmp -- compare linebuf[i] with linebuf[j] }
function CMP(I, J : CHARPOS;
var LINEBUF : CHARBUF) : Integer;
begin
while ((LINEBUF[I] = LINEBUF[J]) and
(LINEBUF[I] <> ENDSTR)) do
begin
I := I+1;
J := J+1
end;
if (LINEBUF[I] = LINEBUF[J]) then
CMP := 0
else if (LINEBUF[I] = ENDSTR) then { 1st is shorter }
CMP := -1
else if (LINEBUF[J] = ENDSTR) then { 2nd is shorter }
CMP := +1
else if (LINEBUF[I] < LINEBUF[J]) then
CMP := -1
else
CMP := +1
end;
{!quick.p!}
{ quick -- quicksort for lines }
procedure QUICK(var LINEPOS : POSBUF;
NLINE : POSZ;
var LINEBUF : CHARBUF);
#include "rquick.p"
begin
RQUICK(1, NLINES)
end;
{!rquick.p!}
{ rquick -- recursive quicksort }
{ See Plauger's column in Computer Language, March 1987, page 16, }
{ and follow-up letters in May 1987, pages 9 & 11, for improvements. }
procedure RQUICK(LOZ, HIZ : Integer);
var
I, J : Integer;
PIVLINE : CHARPOS;
begin
if (LOZ < HIZ) then
begin
I := LOZ;
J := HIZ;
PIVLINE := LINEPOS[J]; { pivot line }
repeat
while (I < J)
and (CMP(LINEPOS[I], PIVLINE, LINEBUF) <= 0) do
I := I+1;
while (J > I)
and (CMP(LINEPOS[J], PIVLINE, LINEBUF) >= 0) do
J := J-1;
if (I < J) then { out of order pair }
EXCHANGE(LINEPOS[I], LINEPOS[J])
until (I >= J);
EXCHANGE(LINEPOS[I], LINEPOS[HIZ]); { move pivot to i }
if (I-LOZ < HIZ-I) then
begin
RQUICK(LOZ, I-1);
RQUICK(I+1, HIZ)
end
else
begin
RQUICK(I+1, HIZ);
RQUICK(LOZ, I-1)
end
end
end;
{!sort.p!}
{ sort -- external sort of text lines }
procedure SORT;
const
MAXCHARS = 10000; { maximum # of text characters }
MAXLINES = 300; { maximum # of lines }
MERGEORDER = 5;
type
CHARPOS = 1..MAXCHARS;
CHARBUF = array[1..MAXCHARS] of CHARACTER;
POSBUF = array[1..MAXLINES] of CHARPOS;
POSZ = 0..MAXLINES;
FDBUF = array[1..MERGEORDER] of FILEDESC;
var
LINEBUF : CHARBUF;
LINEPOS : POSBUF;
NLINES : POSZ;
INFILE : FDBUF;
OUTFILE : FILEDESC;
HIGHZ, LOWZ, LIM : Integer;
DONE : Boolean;
NAME : STRINGZ;
#include "sortproc.p"
begin
HIGHZ := 0;
repeat { initial formation of runs }
DONE := GTEXT(LINEPOS, NLINES, LINEBUF, STDIN);
QUICK(LINEPOS, NLINES, LINEBUF);
HIGHZ := HIGHZ+1;
OUTFILE := MAKEFILE(HIGHZ);
PTEXT(LINEPOS, NLINES, LINEBUF, OUTFILE);
CLOSEZ(OUTFILE)
until (DONE);
LOWZ := 1;
while (LOWZ < HIGHZ) do
begin { merge runs }
LIM := MIN(LOWZ+MERGEORDER-1, HIGHZ);
GOPEN(INFILE, LOWZ, LIM);
HIGHZ := HIGHZ+1;
OUTFILE := MAKEFILE(HIGHZ);
MERGE(INFILE, LIM-LOWZ+1, OUTFILE);
CLOSEZ(OUTFILE);
GREMOVE(INFILE, LOWZ, LIM);
LOWZ := LOWZ+MERGEORDER
end;
GNAME(HIGHZ, NAME); { final cleanup }
OUTFILE := OPEN(NAME, IOREAD);
FCOPY(OUTFILE, STDOUT);
CLOSEZ(OUTFILE);
REMOVE(NAME)
end;
{!sortproc.p!}
{ sortproc -- procedures for sort }
#include "cmp.p"
#include "exchange.p"
#include "gtext.p"
#include "ptext.p"
#include "quick.p"
#include "gname.p"
#include "makefile.p"
#include "gopen.p"
#include "merge.p"
#include "gremove.p"
{!makefile.p!}
{ makefile -- make new file for number n }
function MAKEFILE(N : Integer) : FILEDESC;
var
NAME : STRINGZ;
begin
GNAME(N, NAME);
MAKEFILE := MUSTCREATE(NAME, IOWRITE)
end;
{!gname.p!}
{ gname -- generate unique name for file id n }
procedure GNAME(N : Integer;
var NAME : STRINGZ);
var
JUNK : Integer;
begin
{ setstring(name, 'stemp'); }
NAME[1] := Ord('s');
NAME[2] := Ord('t');
NAME[3] := Ord('e');
NAME[4] := Ord('m');
NAME[5] := Ord('p');
NAME[6] := ENDSTR;
JUNK := ITOC(N, NAME, LENGTHZ(NAME)+1)
end;
{!gopen.p!}
{ gopen -- open group of files f1 ... f2 }
procedure GOPEN(var INFILE : FDBUF;
F1, F2 : Integer);
var
NAME : STRINGZ;
I : 1..MERGEORDER;
begin
for I := 1 to F2-F1+1 do
begin
GNAME(F1+I-1, NAME);
INFILE[I] := MUSTOPEN(NAME, IOREAD)
end
end;
{!gremove.p!}
{ gremove -- remove group of files f1 ... f2 }
procedure GREMOVE(var INFILE : FDBUF;
F1, F2 : Integer);
var
NAME : STRINGZ;
I : 1..MERGEORDER;
begin
for I := 1 to F2-F1+1 do
begin
CLOSEZ(INFILE[I]);
GNAME(F1+I-1, NAME);
REMOVE(NAME)
end
end;
{!merge.p!}
{ merge -- merge infile[1] ... infile [nf] onto outfile }
procedure MERGE(var INFILE : FDBUF;
NF : Integer;
OUTFILE : FILEDESC);
var
I, J : Integer;
LBP : CHARPOS;
TEMP : STRINGZ;
#include "reheap.p"
#include "sccopy.p"
#include "cscopy.p"
begin
J := 0;
for I := 1 to NF do
if (GETLINE(TEMP, INFILE[I], MAXSTR)) then
begin
LBP := (I-1)*MAXSTR+1; { room for longest }
SCCOPY(TEMP, LINEBUF, LBP);
LINEPOS[I] := LBP;
J := J+1
end;
NF := J;
QUICK(LINEPOS, NF, LINEBUF); { make initial heap }
while (NF > 0) do
begin
LBP := LINEPOS[1]; { lowest line }
CSCOPY(LINEBUF, LBP, TEMP);
PUTSTR(TEMP, OUTFILE);
I := LBP div MAXSTR+1; { compute file index }
if (GETLINE(TEMP, INFILE[I], MAXSTR)) then
SCCOPY(TEMP, LINEBUF, LBP)
else
begin { one less input file }
LINEPOS[1] := LINEPOS[NF];
NF := NF-1
end;
REHEAP(LINEPOS, NF, LINEBUF)
end
end;
{!sccopy.p!}
{ sccopy -- copy string s into cb[i]... }
procedure SCCOPY(var S : STRINGZ;
var CB : CHARBUF;
I : CHARPOS);
var
J : Integer;
begin
J := 1;
while (S[J] <> ENDSTR) do
begin
CB[I] := S[J];
J := J+1;
I := I+1
end;
CB[I] := ENDSTR
end;
{!cscopy.p!}
{ cscopy -- copy cs[i]... to string s }
procedure CSCOPY(var CB : CHARBUF;
I : CHARPOS;
var S : STRINGZ);
var
J : Integer;
begin
J := 1;
while (CB[I] <> ENDSTR) do
begin
S[J] := CB[I];
I := I+1;
J := J+1
end;
S[J] := ENDSTR
end;
{!reheap.p!}
{ reheap -- put linebuf[linepos[i]] in proper place in heap }
procedure REHEAP(var LINEPOS : POSBUF;
NF : POSZ;
var LINEBUF : CHARBUF);
var
I, J : Integer;
begin
I := 1;
J := 2*I;
while (J <= NF) do
begin
if (J < NF) then { find smaller child }
if (CMP(LINEPOS[J], LINEPOS[J+1], LINEBUF) > 0) then
J := J+1;
if (CMP(LINEPOS[I], LINEPOS[J], LINEBUF) <= 0) then
I := NF { proper position found; terminate loop }
else
EXCHANGE(LINEPOS[I], LINEPOS[J]); { percolate }
I := J;
J := 2*I
end
end;
{!unique.p!}
{ unique -- remove adjacent duplicate lines }
procedure UNIQUE;
var
BUF : array[0..1] of STRINGZ;
CUR : 0..1;
begin
CUR := 1;
BUF[1-CUR][1] := ENDSTR;
while (GETLINE(BUF[CUR], STDIN, MAXSTR)) do
if (not EQUAL(BUF[CUR], BUF[1-CUR])) then
begin
PUTSTR(BUF[CUR], STDOUT);
CUR := 1-CUR
end
end;
{!kwic.p!}
{ kwic -- make keyword in context index }
procedure KWIC;
const
FOLD = DOLLAR;
var
BUF : STRINGZ;
#include "putrot.p"
begin
while (GETLINE(BUF, STDIN, MAXSTR)) do
PUTROT(BUF)
end;
{!putrot.p!}
{ putrot -- create lines with keyword at front }
procedure PUTROT(var BUF : STRINGZ);
var
I : Integer;
#include "rotate.p"
begin
I := 1;
while ((BUF[I] <> NEWLINE) and
(BUF[I] <> ENDSTR)) do
begin
if (ISALPHANUM(BUF[I])) then
begin
ROTATE(BUF, I); { token starts at "i" }
repeat
I := I+1
until (not ISALPHANUM(BUF[I]))
end;
I := I+1
end
end;
{!rotate.p!}
{ rotate -- output rotated line }
procedure ROTATE(var BUF : STRINGZ;
N : Integer);
var
I : Integer;
begin
I := N;
while ((BUF[I] <> NEWLINE) and
(BUF[I] <> ENDSTR)) do
begin
PUTC(BUF[I]);
I := I+1
end;
PUTC(FOLD);
for I := 1 to N-1 do
PUTC(BUF[I]);
PUTC(NEWLINE)
end;
{!unrotate.p!}
{ unrotate -- unrotate lines rotated by kwic }
procedure UNROTATE;
const
MAXOUT = 80;
MIDDLE = 40;
FOLD = DOLLAR;
var
INBUF, OUTBUF : STRINGZ;
I, J, F : Integer;
begin
while (GETLINE(INBUF, STDIN, MAXSTR)) do
begin
for I := 1 to MAXOUT-1 do
OUTBUF[I] := BLANK;
F := INDEXZ(INBUF, FOLD);
J := MIDDLE-1;
for I := LENGTHZ(INBUF)-1 downto F+1 do
begin
OUTBUF[J] := INBUF[I];
J := J-1;
if (J <= 0) then
J := MAXOUT-1
end;
J := MIDDLE+1;
for I := 1 to F-1 do
begin
OUTBUF[J] := INBUF[I];
J := J mod (MAXOUT-1)+1
end;
for J := 1 to MAXOUT-1 do
if (OUTBUF[J] <> BLANK) then
I := J;
OUTBUF[I+1] := ENDSTR;
PUTSTR(OUTBUF, STDOUT);
PUTC(NEWLINE)
end
end;
{!find.p!}
{ find -- find patterns in text }
procedure FIND;
#include "findcons.p"
var
ARG, LIN, PAT : STRINGZ;
#include "getpat.p"
#include "match.p"
begin
if (not GETARG(1, ARG, MAXSTR)) then
ERROR('usage: find pattern');
if (not GETPAT(ARG, PAT)) then
ERROR('find: illegal pattern');
while (GETLINE(LIN, STDIN, MAXSTR)) do
if (MATCH(LIN, PAT)) then
PUTSTR(LIN, STDOUT)
end;
{!match.p!}
{ match -- find match anywhere on line }
function MATCH(var LINE, PAT : STRINGZ) : Boolean;
var
I, POSZ : Integer;
#include "amatch.p"
begin
POSZ := 0;
I := 1;
while ((LIN[I] <> ENDSTR) and
(POSZ = 0)) do
begin
POSZ := AMATCH(LIN, I, PAT, 1);
I := I+1
end;
MATCH := (POSZ > 0)
end;
{!amatch1.p!}
{ amatch -- with no metacharacters }
function AMATCH(var LIN : STRINGZ;
I : Integer;
var PAT : STRINGZ;
J : Integer) : Integer;
begin
while (PAT[J] <> ENDSTR) do
if (LIN[I] <> PAT[J]) then
I := 0 { no match }
else
begin
I := I+1;
J := J+1
end;
AMATCH := I
end;
{!amatch2.p!}
{ amatch -- with some metacharacters }
function AMATCH(var LIN : STRINGZ;
I : Integer;
var PAT : STRINGZ;
J : Integer) : Integer;
#include "omatch.p"
begin
while ((PAT[J] <> ENDSTR) and
(I > 0)) do
if (OMATCH(LIN, I, PAT, J)) then
J := J+PATSIZE(PAT, J)
else
I := 0; { no match possible }
AMATCH := I
end;
{!amatch.p!}
{ amatch -- look for match of pat[j]... at lin[offset]... }
function AMATCH(var LIN : STRINGZ;
OFFSET : Integer;
var PAT : STRINGZ;
J : Integer) : Integer;
var
I, K : Integer;
DONE : Boolean;
#include "omatch.p"
#include "patsize.p"
begin
DONE := False;
while ((not DONE) and
(PAT[J] <> ENDSTR)) do
if (PAT[J] = CLOSURE) then
begin
J := J+PATSIZE(PAT, J); { step over CLOSURE }
I := OFFSET;
{ match as many as possible }
while ((not DONE) and
(LIN[I] <> ENDSTR)) do
if (not OMATCH(LIN, I, PAT, J)) then
DONE := True;
{ i points to input character that made us fail }
{ match rest of pattern against rest of input }
{ shrink closure by 1 after each failure }
DONE := False;
while ((not DONE) and
(I >= OFFSET)) do
begin
K := AMATCH(LIN, I, PAT, J+PATSIZE(PAT, J));
if (K > 0) then { matched rest of pattern }
DONE := True
else
I := I-1
end;
OFFSET := K; { if k = 0 failure else success }
DONE := True
end
else if (not OMATCH(LIN, OFFSET, PAT, J)) then
begin
OFFSET := 0; { non-closure }
DONE := True
end
else { omatch succeeded on this pattern element }
J := J+PATSIZE(PAT, J);
AMATCH := OFFSET
end;
{!patsize.p!}
{ patsize -- returns size of pattern entry at pat[n] }
function PATSIZE(var PAT : STRINGZ;
N : Integer) : Integer;
begin
if (not(PAT[N] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
ERROR('in patsize: can''t happen')
else
case PAT[N] of
LITCHAR :
PATSIZE := 2;
BOL, EOL, ANY :
PATSIZE := 1;
CCL, NCCL :
PATSIZE := PAT[N+1]+2;
CLOSURE :
PATSIZE := CLOSIZE
end
end;
{!omatch.p!}
{ omatch -- match one pattern element at pat[j] }
function OMATCH(var LIN : STRINGZ;
var I : Integer;
var PAT : STRINGZ;
J : Integer) : Boolean;
var
ADVANCE : -1..1;
#include "locate.p"
begin
ADVANCE := -1;
if (LIN[I] = ENDSTR) then
OMATCH := False
else if (not(PAT[J] in [LITCHAR, BOL, EOL, ANY, CCL, NCCL, CLOSURE])) then
ERROR('in omatch: can''t happen')
else
case PAT[J] of
LITCHAR :
if (LIN[I] = PAT[J+1]) then
ADVANCE := 1;
BOL :
if (I = 1) then
ADVANCE := 0;
ANY :
if (LIN[I] <> NEWLINE) then
ADVANCE := 1;
EOL :
if (LIN[I] = NEWLINE) then
ADVANCE := 0;
CCL :
if (LOCATE(LIN[I], PAT, J+1)) then
ADVANCE := 1;
NCCL :
if ((LIN[I] <> NEWLINE) and
(not LOCATE(LIN[I], PAT, J+1))) then
ADVANCE := 1
end;
if (ADVANCE >= 0) then
begin
I := I+ADVANCE;
OMATCH := True
end
else
OMATCH := False
end;
{!locate.p!}
{ locate -- look for c in character class at pat[offset] }
function LOCATE(C : CHARACTER;
var PAT : STRINGZ;
OFFSET : Integer) : Boolean;
var
I : Integer;
begin
{ size of class is at pat[offset], characters follow }
LOCATE := False;
I := OFFSET+PAT[OFFSET]; { last position }
while (I > OFFSET) do
if (C = PAT[I]) then
begin
LOCATE := True;
I := OFFSET { force loop termination }
end
else
I := I-1
end;
{!patsize1.p!}
{ patsize -- returns size of pattern entry at pat[n] }
function PATSIZE(var PAT : STRINGZ;
N : Integer) : Integer;
begin
if (PAT[N] = LITCHAR) then
PATSIZE := 2
else if (PAT[N] in [BOL, EOL, ANY]) then
PATSIZE := 1
else if ((PAT[N] = CCL) or
(PAT[N] = NCCL)) then
PATSIZE := PAT[N+1]+2
else if (PAT[N] = CLOSURE) then
PATSIZE := CLOSIZE
else
ERROR('in patsize: can''t happen')
end;
{!getpat.p!}
{ getpat -- convert arguments into pattern }
function GETPAT(var ARG, PAT : STRINGZ) : Boolean;
#include "makepat.p"
begin
GETPAT := (MAKEPAT(ARG, 1, ENDSTR, PAT) > 0)
end;
{!makepat.p!}
{ makepat -- make pattern from arg[i], terminate at delims }
function MAKEPAT(var ARG : STRINGZ;
START : Integer;
DELIM : CHARACTER;
var PAT : STRINGZ) : Integer;
var
I, J, LASTJ, LJ : Integer;
DONE, JUNK : Boolean;
#include "getccl.p"
#include "stclose.p"
begin
J := 1; { pat index }
I := START; { arg index }
LASTJ := 1;
DONE := False;
while ((not DONE) and
(ARG[I] <> DELIM) and
(ARG[I] <> ENDSTR)) do
begin
LJ := J;
if (ARG[I] = ANY) then
JUNK := ADDSTR(ANY, PAT, J, MAXPAT)
else if ((ARG[I] = BOL) and
(I = START)) then
JUNK := ADDSTR(BOL, PAT, J, MAXPAT)
else if ((ARG[I] = EOL) and
(ARG[I+1] = DELIM)) then
JUNK := ADDSTR(EOL, PAT, J, MAXPAT)
else if (ARG[I] = CCL) then
DONE := (GETCCL(ARG, I, PAT, J) = False)
else if ((ARG[I] = CLOSURE) and
(I > START)) then
begin
LJ := LASTJ;
if (PAT[LJ] in [BOL, EOL, CLOSURE]) then
DONE := True { force loop termination }
else
STCLOSE(PAT, J, LASTJ)
end
else
begin
JUNK := ADDSTR(LITCHAR, PAT, J, MAXPAT);
JUNK := ADDSTR(ESC(ARG, I), PAT, J, MAXPAT)
end;
LASTJ := LJ;
if (not DONE) then
I := I+1
end;
if ((DONE) or
(ARG[I] <> DELIM)) then { finished early }
MAKEPAT := 0
else if (not ADDSTR(ENDSTR, PAT, J, MAXPAT)) then
MAKEPAT := 0 { no room }
else
MAKEPAT := I { all is well }
end;
{!getccl.p!}
{ getccl -- expand char class at arg[i] into pat[j] }
function GETCCL(var ARG : STRINGZ;
var I : Integer;
var PAT : STRINGZ;
var J : Integer) : Boolean;
var
JSTART : Integer;
JUNK : Boolean;
#include "dodash.p"
begin
I := I+1; { slip over '[' }
if (ARG[I] = NEGATE) then
begin
JUNK := ADDSTR(NCCL, PAT, J, MAXPAT);
I := I+1
end
else
JUNK := ADDSTR(CCL, PAT, J, MAXPAT);
JSTART := J;
JUNK := ADDSTR(0, PAT, J, MAXPAT); { room for count }
DODASH(CCLEND, ARG, I, PAT, J, MAXPAT);
PAT[JSTART] := J-JSTART-1;
GETCCL := (ARG[I] = CCLEND)
end;
{!stclose.p!}
{ stclose -- insert closure entry at pat[j] }
procedure STCLOSE(var PAT : STRINGZ;
var J : Integer;
LASTJ : Integer);
var
JP, JT : Integer;
JUNK : Boolean;
begin
for JP := J-1 downto LASTJ do
begin
JT := JP+CLOSIZE;
JUNK := ADDSTR(PAT[JP], PAT, JT, MAXPAT)
end;
J := J+CLOSIZE;
PAT[LASTJ] := CLOSURE { where original pattern began }
end;
{!findcons.p!}
{ findcons -- const declarations for find }
const
MAXPAT = MAXSTR;
CLOSIZE = 1; { size of a closure entry }
CLOSURE = STAR;
BOL = PERCENT;
EOL = DOLLAR;
ANY = QUESTION;
CCL = LBRACK;
CCLEND = RBRACK;
NEGATE = CARET;
NCCL = EXCLAM; { cannot be the same as NEGATE }
LITCHAR = Ord('c');
{!change.p!}
{ change -- change "from" into "to" on each line }
procedure CHANGE;
#include "findcons.p"
DITTO = 255; {TP7}
var
LIN, PAT, SUB, ARG : STRINGZ;
#include "getpat.p"
#include "getsub.p"
#include "subline.p"
begin
if (not GETARG(1, ARG, MAXSTR)) then
ERROR('usage: change from [to]');
if (not GETPAT(ARG, PAT)) then
ERROR('change: illegal "from" pattern');
if (not GETARG(2, ARG, MAXSTR)) then
ARG[1] := ENDSTR;
if (not GETSUB(ARG, SUB)) then
ERROR('change: illegal "to" string');
while (GETLINE(LIN, STDIN, MAXSTR)) do
SUBLINE(LIN, PAT, SUB)
end;
{!subline.p!}
{ subline -- substitute sub for pat in lin and print }
procedure SUBLINE(var LIN, PAT, SUB : STRINGZ);
var
I, LASTM, M : Integer;
JUNK : Boolean;
#include "amatch.p"
#include "putsub.p"
begin
LASTM := 0;
I := 1;
while (LIN[I] <> ENDSTR) do
begin
M := AMATCH(LIN, I, PAT, 1);
if ((M > 0) and
(LASTM <> M)) then
begin
{ replace matched text }
PUTSUB(LIN, I, M, SUB);
LASTM := M
end;
if ((M = 0) or
(M = I)) then
begin
{ no match or null match }
PUTC(LIN[I]);
I := I+1
end
else { skip matched text }
I := M
end
end;
{!getsub.p!}
{ getsub -- get substitution string into sub }
function GETSUB(var ARG, SUB : STRINGZ) : Boolean;
#include "makesub.p"
begin
GETSUB := (MAKESUB(ARG, 1, ENDSTR, SUB) > 0)
end;
{!makesub.p!}
{ makesub -- make substitution string from arg in sub }
function MAKESUB(var ARG : STRINGZ;
FROM : Integer;
DELIM : CHARACTER;
var SUB : STRINGZ) : Integer;
var
I, J : Integer;
JUNK : Boolean;
begin
J := 1;
I := FROM;
while ((ARG[I] <> DELIM) and
(ARG[I] <> ENDSTR)) do
begin
if (ARG[I] = Ord('&')) then
JUNK := ADDSTR(DITTO, SUB, J, MAXPAT)
else
JUNK := ADDSTR(ESC(ARG, I), SUB, J, MAXPAT);
I := I+1
end;
if (ARG[I] <> DELIM) then { missing delimiter }
MAKESUB := 0
else if (not ADDSTR(ENDSTR, SUB, J, MAXPAT)) then
MAKESUB := 0
else
MAKESUB := I
end;
{!putsub.p!}
{ putsub -- output substitution text }
procedure PUTSUB(var LIN : STRINGZ;
S1, S2 : Integer;
var SUB : STRINGZ);
var
I, J : Integer;
JUNK : Boolean;
begin
I := 1;
while (SUB[I] <> ENDSTR) do
begin
if (SUB[I] = DITTO) then
for J := S1 to S2-1 do
PUTC(LIN[J])
else
PUTC(SUB[I]);
I := I+1
end
end;
{!getlist.p!}
{ getlist -- get list of line nums at lin[i], increment i }
function GETLIST(var LIN : STRINGZ;
var I : Integer;
var STATUS : STCODE) : STCODE;
var
NUM : Integer;
DONE : Boolean;
begin
LINE2 := 0;
NLINES := 0;
DONE := (GETONE(LIN, I, NUM, STATUS) <> OK);
while (not DONE) do
begin
LINE1 := LINE2;
LINE2 := NUM;
NLINES := NLINES+1;
if (LIN[I] = SEMICOL) then
CURLN := NUM;
if ((LIN[I] = COMMA) or
(LIN[I] = SEMICOL)) then
begin
I := I+1;
DONE := (GETONE(LIN, I, NUM, STATUS) <> OK)
end
else
DONE := True
end;
NLINES := MIN(NLINES, 2);
if (NLINES = 0) then
LINE2 := CURLN;
if (NLINES <= 1) then
LINE1 := LINE2;
if (STATUS <> ERR) then
STATUS := OK;
GETLIST := STATUS
end;
{!getone.p!}
{ getone -- get one line number expression }
function GETONE(var LIN : STRINGZ;
var I, NUM : Integer;
var STATUS : STCODE) : STCODE;
var
ISTART, MUL, PNUM : Integer;
begin
ISTART := I;
NUM := 0;
if (GETNUM(LIN, I, NUM, STATUS) = OK) then { 1st term }
repeat { + or - terms }
SKIPBL(LIN, I);
if ((LIN[I] <> PLUS) and
(LIN[I] <> MINUS)) then
STATUS := ENDDATA
else
begin
if (LIN[I] = PLUS) then
MUL := +1
else
MUL := -1;
I := I+1;
if (GETNUM(LIN, I, PNUM, STATUS) = OK) then
NUM := NUM+MUL*PNUM;
if (STATUS = ENDDATA) then
STATUS := ERR
end
until (STATUS <> OK);
if ((NUM < 0) or
(NUM > LASTLN)) then
STATUS := ERR;
if (STATUS <> ERR) then
begin
if (I <= ISTART) then
STATUS := ENDDATA
else
STATUS := OK
end;
GETONE := STATUS
end;
{!skipbl.p!}
{ skipbl -- skip blanks and tabs at s[i]... }
procedure SKIPBL(var S : STRINGZ;
var I : Integer);
begin
while ((S[I] = BLANK) or
(S[I] = TAB)) do
I := I+1
end;
{!getnum.p!}
{ getnum -- get single line number component }
function GETNUM(var LIN : STRINGZ;
var I, NUM : Integer;
var STATUS : STCODE) : STCODE;
begin
STATUS := OK;
SKIPBL(LIN, I);
if (ISDIGIT(LIN[I])) then
begin
NUM := CTOI(LIN, I);
I := I-1 { move back; to be advanced at end }
end
else if (LIN[I] = CURLINE) then
NUM := CURLN
else if (LIN[I] = LASTLINE) then
NUM := LASTLN
else if ((LIN[I] = SCAN) or
(LIN[I] = BACKSCAN)) then
begin
if (OPTPAT(LIN, I) = ERR) then { build pattern }
STATUS := ERR
else
STATUS := PATSCAN(LIN[I], NUM)
end
else
STATUS := ENDDATA;
if (STATUS = OK) then
I := I+1; { next character to be examined }
GETNUM := STATUS
end;
{!optpat.p!}
{ optpat -- get optional pattern from lin[i], increment i }
function OPTPAT(var LIN : STRINGZ;
var I : Integer) : STCODE;
#include "makepat.p"
begin
if (LIN[I] = ENDSTR) then
I := 0
else if (LIN[I+1] = ENDSTR) then
I := 0
else if (LIN[I+1] = LIN[I]) then { repeated delimiter }
I := I+1 { leave existing pattern alone }
else
I := MAKEPAT(LIN, I+1, LIN[I], PAT);
if (PAT[1] = ENDSTR) then
I := 0;
if (I = 0) then
begin
PAT[1] := ENDSTR;
OPTPAT := ERR
end
else
OPTPAT := OK
end;
{!patscan.p!}
{ patscan -- find next occurrence of pattern after line n }
function PATSCAN(WAY : CHARACTER;
var N : Integer) : STCODE;
var
DONE : Boolean;
LINE : STRINGZ;
begin
N := CURLN;
PATSCAN := ERR;
DONE := False;
repeat
if (WAY = SCAN) then
N := NEXTLN(N)
else
N := PREVLN(N);
GETTXT(N, LINE);
if (MATCH(LINE, PAT)) then
begin
PATSCAN := OK;
DONE := True
end
until ((N = CURLN) or
(DONE))
end;
{!nextln.p!}
{ nextln -- get line after n }
function NEXTLN(N : Integer) : Integer;
begin
if (N >= LASTLN) then
NEXTLN := 0
else
NEXTLN := N+1
end;
{!prevln.p!}
{ prevln -- get line before n }
function PREVLN(N : Integer) : Integer;
begin
if (N <= 0) then
PREVLN := LASTLN
else
PREVLN := N-1
end;
{!default.p!}
{ default -- set defaulted line numbers }
function DEFAULT(DEF1, DEF2 : Integer;
var STATUS : STCODE) : STCODE;
begin
if (NLINES = 0) then
begin
LINE1 := DEF1;
LINE2 := DEF2
end;
if ((LINE1 > LINE2) or
(LINE1 <= 0)) then
STATUS := ERR
else
STATUS := OK;
DEFAULT := STATUS
end;
{!doprint.p!}
{ doprint -- print lines n1 through n2 }
function DOPRINT(N1, N2 : Integer) : STCODE;
var
I : Integer;
LINE : STRINGZ;
begin
if (N1 <= 0) then
DOPRINT := ERR
else
begin
for I := N1 to N2 do
begin
GETTXT(I, LINE);
PUTSTR(LINE, STDOUT)
end;
CURLN := N2;
DOPRINT := OK
end
end;
{!appendz.p!}
{ appendz -- append lines after "line" }
function APPENDZ(LINE : Integer;
GLOB : Boolean) : STCODE;
var
INLINEZ : STRINGZ;
STAT : STCODE;
DONE : Boolean;
begin
if (GLOB) then
STAT := ERR
else
begin
CURLN := LINE;
STAT := OK;
DONE := False;
while ((not DONE) and
(STAT = OK)) do
if (not GETLINE(INLINEZ, STDIN, MAXSTR)) then
STAT := ENDDATA
else if (INLINEZ[1] = PERIOD)
and (INLINEZ[2] = NEWLINE) then
DONE := True
else if (PUTTXT(INLINEZ) = ERR) then
STAT := ERR
end;
APPENDZ := STAT
end;
{!clrbuf1.p!}
{ clrbuf -- (in memory) initialize for new file }
procedure CLRBUF;
begin
{ nothing to do }
end;
{!gettxt1.p!}
{ gettxt -- (in memory) get text from line n into s }
procedure GETTXT(N : Integer;
var S : STRINGZ);
begin
SCOPY(BUF[N].TXT, 1, S, 1)
end;
{!blkmove.p!}
{ blkmove -- move block of lines n1..n2 to after n3 }
procedure BLKMOVE(N1, N2, N3 : Integer);
begin
if (N3 < N1-1) then
begin
REVERSE(N3+1, N1-1);
REVERSE(N1, N2);
REVERSE(N3+1, N2)
end
else if (N3 > N2) then
begin
REVERSE(N1, N2);
REVERSE(N2+1, N3);
REVERSE(N1, N3)
end
end;
{!reverse.p!}
{ reverse -- reverse buf[n1]...buf[n2] }
procedure REVERSE(N1, N2 : Integer);
var
TEMP : BUFTYPE;
begin
while (N1 < N2) do
begin
TEMP := BUF[N1];
BUF[N1] := BUF[N2];
BUF[N2] := TEMP;
N1 := N1+1;
N2 := N2-1
end
end;
{!setbuf1.p!}
{ setbuf -- (in memory) initialize line storage buffer }
procedure SETBUF;
var
NULL : STRINGZ; { value is '' }
begin
NULL[1] := ENDSTR;
SCOPY(NULL, 1, BUF[0].TXT, 1);
CURLN := 0;
LASTLN := 0;
end;
{!puttxt1.p!}
{ puttxt -- (in memory) put text from lin after curln }
function PUTTXT(var LIN : STRINGZ) : STCODE;
begin
PUTTXT := ERR;
if (LASTLN < MAXLINES) then
begin
LASTLN := LASTLN+1;
SCOPY(LIN, 1, BUF[LASTLN].TXT, 1);
PUTMARK(LASTLN, False);
BLKMOVE(LASTLN, LASTLN, CURLN);
CURLN := CURLN+1;
PUTTXT := OK
end
end;
{!ckp.p!}
{ ckp -- check for "p" after command }
function CKP(var LIN : STRINGZ;
I : Integer;
var PFLAG : Boolean;
var STATUS : STCODE) : STCODE;
begin
SKIPBL(LIN, I);
if (LIN[I] = PCMD) then
begin
I := I+1;
PFLAG := True
end
else
PFLAG := False;
if (LIN[I] = NEWLINE) then
STATUS := OK
else
STATUS := ERR;
CKP := STATUS
end;
{!lndelete.p!}
{ lndelete -- delete lines n1 through n2 }
function LNDELETE(N1, N2 : Integer;
var STATUS : STCODE) : STCODE;
begin
if (N1 <= 0) then
STATUS := ERR
else
begin
BLKMOVE(N1, N2, LASTLN);
LASTLN := LASTLN-(N2-N1+1);
CURLN := PREVLN(N1);
STATUS := OK
end;
LNDELETE := STATUS
end;
{!movez.p!}
{ movez -- move line1 through line2 after line3 }
function MOVEZ(LINE3 : Integer) : STCODE;
begin
if ((LINE1 <= 0) or
((LINE3 >= LINE1) and
(LINE3 < LINE2))) then
MOVEZ := ERR
else
begin
BLKMOVE(LINE1, LINE2, LINE3);
if (LINE3 > LINE1) then
CURLN := LINE3
else
CURLN := LINE3+(LINE2-LINE1+1);
MOVEZ := OK
end
end;
{!getrhs.p!}
{ getrhs -- get right hand side of "s" command }
function GETRHS(var LIN : STRINGZ;
var I : Integer;
var SUB : STRINGZ;
var GFLAG : Boolean) : STCODE;
begin
GETRHS := OK;
if (LIN[I] = ENDSTR) then
GETRHS := ERR
else if (LIN[I+1] = ENDSTR) then
GETRHS := ERR
else
begin
I := MAKESUB(LIN, I+1, LIN[I], SUB);
if (I = 0) then
GETRHS := ERR
else if (LIN[I+1] = Ord('g')) then
begin
I := I+1;
GFLAG := True
end
else
GFLAG := False
end
end;
{!subst.p!}
{ subst -- substitute "sub" for occurrences of pattern }
function SUBST(var SUB : STRINGZ;
GFLAG, GLOB : Boolean) : STCODE;
var
NEWZ, OLD : STRINGZ;
J, K, LASTM, LINE, M : Integer;
STAT : STCODE;
DONE, SUBBED, JUNK : Boolean;
begin
if (GLOB) then
STAT := OK
else
STAT := ERR;
DONE := (LINE1 <= 0);
LINE := LINE1;
while ((not DONE) and
(LINE <= LINE2)) do
begin
J := 1;
SUBBED := False;
GETTXT(LINE, OLD);
LASTM := 0;
K := 1;
while (OLD[K] <> ENDSTR) do
begin
if ((GFLAG) or
(not SUBBED)) then
M := AMATCH(OLD, K, PAT, 1)
else
M := 0;
if ((M > 0) and
(LASTM <> M)) then
begin
{ replace matched text }
SUBBED := True;
CATSUB(OLD, K, M, SUB, NEWZ, J, MAXSTR);
LASTM := M
end;
if ((M = 0) or
(M = K)) then
begin
{ no match or null match }
JUNK := ADDSTR(OLD[K], NEWZ, J, MAXSTR);
K := K+1
end
else { skipped matched text }
K := M
end;
if (SUBBED) then
begin
if (not ADDSTR(ENDSTR, NEWZ, J, MAXSTR)) then
begin
STAT := ERR;
DONE := True
end
else
begin
STAT := LNDELETE(LINE, LINE, STATUS);
STAT := PUTTXT(NEWZ);
LINE2 := LINE2+CURLN-LINE;
LINE := CURLN;
if (STAT = ERR) then
DONE := True
else
STAT := OK
end
end;
LINE := LINE+1
end;
SUBST := STAT
end;
{!catsub.p!}
{ catsub -- add replacement text to end of new }
procedure CATSUB(var LIN : STRINGZ;
S1, S2 : Integer;
var SUB : STRINGZ;
var NEWZ : STRINGZ;
var K : Integer;
MAXNEW : Integer);
var
I, J : Integer;
JUNK : Boolean;
begin
I := 1;
while (SUB[I] <> ENDSTR) do
begin
if (SUB[I] = DITTO) then
for J := S1 to S2-1 do
JUNK := ADDSTR(LIN[J], NEWZ, K, MAXNEW)
else
JUNK := ADDSTR(SUB[I], NEWZ, K, MAXNEW);
I := I+1
end
end;
{!getfn.p!}
{ getfn -- get file name from lin[i]... }
function GETFN(var LIN : STRINGZ;
var I : Integer;
var FIL : STRINGZ) : STCODE;
var
K : Integer;
STAT : STCODE;
#include "getword.p"
begin
STAT := ERR;
if (LIN[I+1] = BLANK) then
begin
K := GETWORD(LIN, I+2, FIL); { get new filename }
if (K > 0) then
if (LIN[K] = NEWLINE) then
STAT := OK
end
else if ((LIN[I+1] = NEWLINE) and
(SAVEFILE[1] <> ENDSTR)) then
begin
SCOPY(SAVEFILE, 1, FIL, 1);
STAT := OK;
end;
if ((STAT = OK) and
(SAVEFILE[1] = ENDSTR)) then
SCOPY(FIL, 1, SAVEFILE, 1); { save if no old one }
GETFN := STAT
end;
{!doread.p!}
{ doread -- read "fil" after line n }
function DOREAD(N : Integer;
var FIL : STRINGZ) : STCODE;
var
COUNT : Integer;
T : Boolean;
STAT : STCODE;
FD : FILEDESC;
INLINEZ : STRINGZ;
begin
FD := OPEN(FIL, IOREAD);
if (FD = IOERROR) then
STAT := ERR
else
begin
CURLN := N;
STAT := OK;
COUNT := 0;
repeat
T := GETLINE(INLINEZ, FD, MAXSTR);
if (T) then
begin
STAT := PUTTXT(INLINEZ);
if (STAT <> ERR) then
COUNT := COUNT+1
end
until ((STAT <> OK) or
(T = False));
CLOSEZ(FD);
PUTDEC(COUNT, 1);
PUTC(NEWLINE)
end;
DOREAD := STAT
end;
{!dowrite.p!}
{ dowrite -- write lines n1..n2 into file }
function DOWRITE(N1, N2 : Integer;
var FIL : STRINGZ) : STCODE;
var
I : Integer;
FD : FILEDESC;
LINE : STRINGZ;
begin
FD := CREATE(FIL, IOWRITE);
if (FD = IOERROR) then
DOWRITE := ERR
else
begin
for I := N1 to N2 do
begin
GETTXT(I, LINE);
PUTSTR(LINE, FD)
end;
CLOSEZ(FD);
PUTDEC(N2-N1+1, 1);
PUTC(NEWLINE);
DOWRITE := OK
end
end;
{!ckglob.p!}
{ ckglob -- if global prefix, mark lines to be affected }
function CKGLOB(var LIN : STRINGZ;
var I : Integer;
var STATUS : STCODE) : STCODE;
var
N : Integer;
GFLAG : Boolean;
TEMP : STRINGZ;
begin
if ((LIN[I] <> GCMD) and
(LIN[I] <> XCMD)) then
STATUS := ENDDATA
else
begin
GFLAG := (LIN[I] = GCMD);
I := I+1;
if (OPTPAT(LIN, I) = ERR) then
STATUS := ERR
else if (DEFAULT(1, LASTLN, STATUS) <> ERR) then
begin
I := I+1; { mark affected lines }
for N := LINE1 to LINE2 do
begin
GETTXT(N, TEMP);
PUTMARK(N, (MATCH(TEMP, PAT) = GFLAG))
end;
for N := 1 to LINE1-1 do { erase other marks }
PUTMARK(N, False);
for N := LINE2+1 to LASTLN do
PUTMARK(N, False);
STATUS := OK
end
end;
CKGLOB := STATUS
end;
{!getmark.p!}
{ getmark -- get mark from nth line }
function GETMARK(N : Integer) : Boolean;
begin
GETMARK := BUF[N].MARKZ
end;
{!putmark.p!}
{ putmark -- put mark m on nth line }
procedure PUTMARK(N : Integer;
M : Boolean);
begin
BUF[N].MARKZ := M
end;
{!doglob.p!}
{ doglob -- do command at lin[i] on all marked lines }
function DOGLOB(var LIN : STRINGZ;
var I, CURSAVE : Integer;
var STATUS : STCODE) : STCODE;
var
COUNT, ISTART, N : Integer;
begin
STATUS := OK;
COUNT := 0;
N := LINE1;
ISTART := I;
repeat
if (GETMARK(N)) then
begin
PUTMARK(N, False);
CURLN := N;
CURSAVE := CURLN;
I := ISTART;
if (DOCMD(LIN, I, True, STATUS) = OK) then
COUNT := 0
end
else
begin
N := NEXTLN(N);
COUNT := COUNT+1
end
until ((COUNT > LASTLN) or
(STATUS <> OK));
DOGLOB := STATUS
end;
{!docmd.p!}
{ docmd -- handle all commands except globals }
function DOCMD(var LIN : STRINGZ;
var I : Integer;
GLOB : Boolean;
var STATUS : STCODE) : STCODE;
var
FIL, SUB : STRINGZ;
LINE3 : Integer;
GFLAG, PFLAG : Boolean;
begin
PFLAG := False; { may be set by d, m, s }
STATUS := ERR;
if (LIN[I] = PCMD) then
begin
if (LIN[I+1] = NEWLINE) then
if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
STATUS := DOPRINT(LINE1, LINE2)
end
else if (LIN[I] = NEWLINE) then
begin
if (NLINES = 0) then
LINE2 := NEXTLN(CURLN);
STATUS := DOPRINT(LINE2, LINE2)
end
else if (LIN[I] = QCMD) then
begin
if ((LIN[I+1] = NEWLINE) and
(NLINES = 0) and
(not GLOB)) then
STATUS := ENDDATA
end
else if (LIN[I] = ACMD) then
begin
if (LIN[I+1] = NEWLINE) then
STATUS := APPENDZ(LINE2, GLOB)
end
else if (LIN[I] = CCMD) then
begin
if (LIN[I+1] = NEWLINE) then
if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
if (LNDELETE(LINE1, LINE2, STATUS) = OK) then
STATUS := APPENDZ(PREVLN(LINE1), GLOB)
end
else if (LIN[I] = DCMD) then
begin
if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
if (LNDELETE(LINE1, LINE2, STATUS) = OK) then
if (NEXTLN(CURLN) <> 0) then
CURLN := NEXTLN(CURLN)
end
else if (LIN[I] = ICMD) then
begin
if (LIN[I+1] = NEWLINE) then
begin
if (LINE2 = 0) then
STATUS := APPENDZ(0, GLOB)
else
STATUS := APPENDZ(PREVLN(LINE2), GLOB)
end
end
else if (LIN[I] = EQCMD) then
begin
if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
begin
PUTDEC(LINE2, 1);
PUTC(NEWLINE)
end
end
else if (LIN[I] = MCMD) then
begin
I := I+1;
if (GETONE(LIN, I, LINE3, STATUS) = ENDDATA) then
STATUS := ERR;
if (STATUS = OK) then
if (CKP(LIN, I, PFLAG, STATUS) = OK) then
if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
STATUS := MOVEZ(LINE3)
end
else if (LIN[I] = SCMD) then
begin
I := I+1;
if (OPTPAT(LIN, I) = OK) then
if (GETRHS(LIN, I, SUB, GFLAG) = OK) then
if (CKP(LIN, I+1, PFLAG, STATUS) = OK) then
if (DEFAULT(CURLN, CURLN, STATUS) = OK) then
STATUS := SUBST(SUB, GFLAG, GLOB)
end
else if (LIN[I] = ECMD) then
begin
if (NLINES = 0) then
if (GETFN(LIN, I, FIL) = OK) then
begin
SCOPY(FIL, 1, SAVEFILE, 1);
CLRBUF;
SETBUF;
STATUS := DOREAD(0, FIL)
end
end
else if (LIN[I] = FCMD) then
begin
if (NLINES = 0) then
if (GETFN(LIN, I, FIL) = OK) then
begin
SCOPY(FIL, 1, SAVEFILE, 1);
PUTSTR(SAVEFILE, STDOUT);
PUTC(NEWLINE);
STATUS := OK
end
end
else if (LIN[I] = RCMD) then
begin
if (GETFN(LIN, I, FIL) = OK) then
STATUS := DOREAD(LINE2, FIL)
end
else if (LIN[I] = WCMD) then
begin
if (GETFN(LIN, I, FIL) = OK) then
if (DEFAULT(1, LASTLN, STATUS) = OK) then
STATUS := DOWRITE(LINE1, LINE2, FIL)
end;
{ else status is ERR }
if ((STATUS = OK) and
(PFLAG)) then
STATUS := DOPRINT(CURLN, CURLN);
DOCMD := STATUS
end;
{!edit1.p!}
{ edit -- main routine for text editor }
procedure EDIT;
#include "editcons.p"
#include "edittyp1.p"
#include "editvar1.p"
CURSAVE, I : Integer;
STATUS : STCODE;
MORE : Boolean;
#include "editpro1.p"
begin
SETBUF;
PAT[1] := ENDSTR;
SAVEFILE[1] := ENDSTR;
if (GETARG(1, SAVEFILE, MAXSTR)) then
if (DOREAD(0, SAVEFILE) = ERR) then
MESSAGE('?');
MORE := GETLINE(LIN, STDIN, MAXSTR);
while (MORE) do
begin
I := 1;
CURSAVE := CURLN;
if (GETLIST(LIN, I, STATUS) = OK) then
begin
if (CKGLOB(LIN, I, STATUS) = OK) then
STATUS := DOGLOB(LIN, I, CURSAVE, STATUS)
else if (STATUS <> ERR) then
STATUS := DOCMD(LIN, I, False, STATUS)
{ else ERR, do nothing }
end;
if (STATUS = ERR) then
begin
MESSAGE('?');
CURLN := MIN(CURSAVE, LASTLN)
end
else if (STATUS = ENDDATA) then
MORE := False;
{ else OK }
if (MORE) then
MORE := GETLINE(LIN, STDIN, MAXSTR)
end;
CLRBUF
end;
{!editvar1.p!}
{ editvar -- (in-memory) variables for edit }
var
BUF : array[0..MAXLINES] of BUFTYPE;
LINE1 : Integer; { first line number }
LINE2 : Integer; { second line number }
NLINES : Integer; { # of line numbers specified }
CURLN : Integer; { current line - value of dot }
LASTLN : Integer; { last line - value of $ }
PAT : STRINGZ; { pattern }
LIN : STRINGZ; { input line }
SAVEFILE : STRINGZ; { remembered file name }
{!editpro1.p!}
{ editproc -- procedures for edit }
#include "edprim1.p" {editor buffer primitives }
#include "amatch.p"
#include "match.p"
#include "skipbl.p"
#include "optpat.p"
#include "nextln.p"
#include "prevln.p"
#include "patscan.p"
#include "getnum.p"
#include "getone.p"
#include "getlist.p"
#include "appendz.p"
#include "lndelete.p"
#include "doprint.p"
#include "doread.p"
#include "dowrite.p"
#include "movez.p"
#include "makesub.p"
#include "getrhs.p"
#include "catsub.p"
#include "subst.p"
#include "ckp.p"
#include "default.p"
#include "getfn.p"
#include "docmd.p"
#include "ckglob.p"
#include "doglob.p"
{!edprim1.p!}
{ edprim -- editor buffer primitives }
#include "setbuf1.p"
#include "clrbuf1.p"
#include "reverse.p"
#include "blkmove.p"
#include "putmark.p"
#include "getmark.p"
#include "puttxt1.p"
#include "gettxt1.p"
{!editcons.p!}
{ editcons -- const declarations for edit }
const
MAXLINES = 100; { set small for testing }
MAXPAT = MAXSTR;
CLOSIZE = 1; { size of a closure entry }
DITTO = 255; {TP7}
CLOSURE = STAR;
BOL = PERCENT;
EOL = DOLLAR;
ANY = QUESTION;
CCL = LBRACK;
CCLEND = RBRACK;
NEGATE = CARET;
NCCL = EXCLAM;
LITCHAR = Ord('c');
CURLINE = PERIOD;
LASTLINE = DOLLAR;
SCAN = Ord('/');
BACKSCAN = Ord('\');
ACMD = Ord('a');
CCMD = Ord('c');
DCMD = Ord('d');
ECMD = Ord('e');
EQCMD = EQUALS;
FCMD = Ord('f');
GCMD = Ord('g');
ICMD = Ord('i');
MCMD = Ord('m');
PCMD = Ord('p');
QCMD = Ord('q');
RCMD = Ord('r');
SCMD = Ord('s');
WCMD = Ord('w');
XCMD = Ord('x');
{!edittyp1.p!}
{ edittype -- types for in-memory version of edit }
type
STCODE = (ENDDATA, ERR, OK); { status returns }
BUFTYPE = record { in-memory edit buffer entry }
TXT : STRINGZ; { text of line }
MARKZ : Boolean; { mark for line }
end;
{!edprim2.p!}
{ edprim -- (scratch file) editor buffer primitives }
#include "setbuf2.p"
#include "clrbuf2.p"
#include "reverse.p"
#include "blkmove.p"
#include "putmark.p"
#include "getmark.p"
#include "puttxt2.p"
#include "gettxt2.p"
{!edittyp2.p!}
{ edittype -- types for scratch-file of edit }
type
STCODE = (ENDDATA, ERR, OK);
BUFTYPE = record
TXT : Integer; { text of line }
MARKZ : Boolean; { mark for line }
end;
{!editvar2.p!}
{ editvar -- (scratch file) variables for edit }
var
BUF : array[0..MAXLINES] of BUFTYPE;
LINE1 : Integer; { first line number }
LINE2 : Integer; { second line number }
NLINES : Integer; { # of line numbers specified }
CURLN : Integer; { current line - value of dot }
LASTLN : Integer; { last line - value of $ }
PAT : STRINGZ; { pattern }
LIN : STRINGZ; { input line }
SAVEFILE : STRINGZ; { remembered file name }
SCROUT : FILEDESC; { scratch input fd }
SCRIN : FILEDESC; { scratch output fd }
RECIN : Integer; { next record to read from scrin }
RECOUT : Integer; { next record to write on scrout }
EDITTEMP : STRINGZ; { temp file name 'edtemp' }
{!puttxt2.p!}
{ puttxt -- (scratch file) put text from lin after curln }
function PUTTXT(var LIN : STRINGZ) : STCODE;
begin
PUTTXT := ERR;
if (LASTLN < MAXLINES) then
begin
LASTLN := LASTLN+1;
PUTSTR(LIN, SCROUT);
PUTMARK(LASTLN, False);
BUF[LASTLN].TXT := RECOUT;
RECOUT := RECOUT+1;
BLKMOVE(LASTLN, LASTLN, CURLN);
CURLN := CURLN+1;
PUTTXT := OK
end
end;
{!gettxt2.p!}
{ gettxt -- (scratch file) get text from line n into s }
procedure GETTXT(N : Integer;
var S : STRINGZ);
var
JUNK : Boolean;
#include "seekz.p"
begin
if (N = 0) then
S[1] := ENDSTR
else
begin
SEEKZ(BUF[N].TXT, SCRIN);
RECIN := RECIN+1;
JUNK := GETLINE(S, SCRIN, MAXSTR)
end
end;
{!setbuf2.p!}
{ setbuf -- (scratch file) create scratch file, set up line 0 }
procedure SETBUF;
begin
{ setstring(edittemp, 'edtemp'); }
EDITTEMP[1] := Ord('e');
EDITTEMP[2] := Ord('d');
EDITTEMP[3] := Ord('t');
EDITTEMP[4] := Ord('e');
EDITTEMP[5] := Ord('m');
EDITTEMP[6] := Ord('p');
EDITTEMP[7] := ENDSTR;
SCROUT := MUSTCREATE(EDITTEMP, IOWRITE);
SCRIN := MUSTOPEN(EDITTEMP, IOREAD);
RECOUT := 1;
RECIN := 1;
CURLN := 0;
LASTLN := 0;
end;
{!clrbuf2.p!}
{ clrbuf -- (scratch file) initialize for new file }
procedure CLRBUF;
begin
CLOSEZ(SCRIN);
CLOSEZ(SCROUT);
REMOVE(EDITTEMP)
end;
{!edit2.p!}
{ edit -- main routine for text editor }
procedure EDIT;
#include "editcons.p"
#include "edittyp2.p"
#include "editvar2.p"
CURSAVE, I : Integer;
STATUS : STCODE;
MORE : Boolean;
#include "editpro2.p"
begin
SETBUF;
PAT[1] := ENDSTR;
SAVEFILE[1] := ENDSTR;
if (GETARG(1, SAVEFILE, MAXSTR)) then
if (DOREAD(0, SAVEFILE) = ERR) then
MESSAGE('?');
MORE := GETLINE(LIN, STDIN, MAXSTR);
while (MORE) do
begin
I := 1;
CURSAVE := CURLN;
if (GETLIST(LIN, I, STATUS) = OK) then
begin
if (CKGLOB(LIN, I, STATUS) = OK) then
STATUS := DOGLOB(LIN, I, CURSAVE, STATUS)
else if (STATUS <> ERR) then
STATUS := DOCMD(LIN, I, False, STATUS)
{ else ERR, do nothing }
end;
if (STATUS = ERR) then
begin
MESSAGE('?');
CURLN := MIN(CURSAVE, LASTLN)
end
else if (STATUS = ENDDATA) then
MORE := False;
{ else OK }
if (MORE) then
MORE := GETLINE(LIN, STDIN, MAXSTR)
end;
CLRBUF
end;
{!editpro2.p!}
{ editproc -- procedures for edit }
#include "edprim2.p" {editor buffer primitives }
#include "amatch.p"
#include "match.p"
#include "skipbl.p"
#include "optpat.p"
#include "nextln.p"
#include "prevln.p"
#include "patscan.p"
#include "getnum.p"
#include "getone.p"
#include "getlist.p"
#include "appendz.p"
#include "lndelete.p"
#include "doprint.p"
#include "doread.p"
#include "dowrite.p"
#include "movez.p"
#include "makesub.p"
#include "getrhs.p"
#include "catsub.p"
#include "subst.p"
#include "ckp.p"
#include "default.p"
#include "getfn.p"
#include "docmd.p"
#include "ckglob.p"
#include "doglob.p"
{!command.p!}
{ command -- perform formatting command }
procedure COMMAND(var BUF : STRINGZ);
var
CMD : CMDTYPE;
ARGTYPE, SPVAL, VALZ : Integer;
begin
CMD := GETCMD(BUF);
if (CMD <> UNKNOWN) then
VALZ := GETVAL(BUF, ARGTYPE);
case CMD of
FI :
begin
BREAKZ;
FILL := True
end;
NF :
begin
BREAKZ;
FILL := False
end;
BR :
BREAKZ;
LS :
SETPARAM(LSVAL, VALZ, ARGTYPE, 1, 1, HUGE);
CE :
begin
BREAKZ;
SETPARAM(CEVAL, VALZ, ARGTYPE, 1, 0, HUGE)
end;
UL :
SETPARAM(ULVAL, VALZ, ARGTYPE, 1, 0, HUGE);
HE :
GETTL(BUF, HEADER);
FO :
GETTL(BUF, FOOTER);
BP :
begin
PAGE;
SETPARAM(CURPAGE, VALZ, ARGTYPE, CURPAGE+1, -HUGE, HUGE);
NEWPAGE := CURPAGE
end;
SP :
begin
SETPARAM(SPVAL, VALZ, ARGTYPE, 1, 0, HUGE);
SPACE(SPVAL)
end;
IND :
SETPARAM(INVAL, VALZ, ARGTYPE, 0, 0, RMVAL-1);
RM :
SETPARAM(INVAL, VALZ, ARGTYPE, PAGEWIDTH, INVAL+TIVAL+1, HUGE);
TI :
begin
BREAKZ;
SETPARAM(TIVAL, VALZ, ARGTYPE, 0, -HUGE, RMVAL)
end;
PL :
begin
SETPARAM(PLVAL, VALZ, ARGTYPE, PAGELEN,
M1VAL+M2VAL+M3VAL+M4VAL+1, HUGE);
BOTTOM := PLVAL-M3VAL-M4VAL
end;
UNKNOWN :
{ ignore }
end
end;
{!getcmd.p!}
{ getcmd -- decode command type }
function GETCMD(var BUF : STRINGZ) : CMDTYPE;
var
CMD : packed array[1..2] of Char;
begin
CMD[1] := Chr(BUF[2]);
CMD[2] := Chr(BUF[3]);
if (CMD = 'fi') then
GETCMD := FI
else if (CMD = 'nf') then
GETCMD := NF
else if (CMD = 'br') then
GETCMD := BR
else if (CMD = 'ls') then
GETCMD := LS
else if (CMD = 'bp') then
GETCMD := BP
else if (CMD = 'sp') then
GETCMD := SP
else if (CMD = 'in') then
GETCMD := IND
else if (CMD = 'rm') then
GETCMD := RM
else if (CMD = 'ce') then
GETCMD := CE
else if (CMD = 'ti') then
GETCMD := TI
else if (CMD = 'ul') then
GETCMD := UL
else if (CMD = 'he') then
GETCMD := HE
else if (CMD = 'fo') then
GETCMD := FO
else if (CMD = 'pl') then
GETCMD := PL
else
GETCMD := UNKNOWN
end;
{!getval.p!}
{ getval -- evaluate optional numeric argument }
function GETVAL(var BUF : STRINGZ;
var ARGTYPE : Integer) : Integer;
var
I : Integer;
begin
I := 1; { skip over command name }
while (not(BUF[I] in [BLANK, TAB, NEWLINE])) do
I := I+1;
SKIPBL(BUF, I); { find argument }
ARGTYPE := BUF[I];
if ((ARGTYPE = PLUS) or
(ARGTYPE = MINUS)) then
I := I+1;
GETVAL := CTOI(BUF, I)
end;
{!setparam.p!}
{ setparam -- set parameter and check range }
procedure SETPARAM(var PARAM : Integer;
VALZ, ARGTYPE, DEFVAL, MINVAL, MAXVAL : Integer);
begin
if (ARGTYPE = NEWLINE) then { defaulted }
PARAM := DEFVAL
else if (ARGTYPE = PLUS) then { relative + }
PARAM := PARAM+VALZ
else if (ARGTYPE = MINUS) then { relative - }
PARAM := PARAM-VALZ
else { absolute }
PARAM := VALZ;
PARAM := MIN(PARAM, MAXVAL);
PARAM := MAX(PARAM, MINVAL)
end;
{!textz1.p!}
{ textz -- process text lines (interim version 1) }
procedure TEXTZ(var INBUF : STRINGZ);
begin
PUT(INBUF)
end;
{!put.p!}
{ put -- put out line with proper spacing and indenting }
procedure PUT(var BUF : STRINGZ);
var
I : Integer;
begin
if ((LINENO <= 0) or
(LINENO > BOTTOM)) then
PUTHEAD;
for I := 1 to INVAL+TIVAL do { indenting }
PUTC(BLANK);
TIVAL := 0;
PUTSTR(BUF, STDOUT);
SKIP(MIN(LSVAL-1, BOTTOM-LINENO));
LINENO := LINENO+LSVAL;
if (LINENO > BOTTOM) then
PUTFOOT
end;
{!puthead.p!}
{ puthead -- put out page header }
procedure PUTHEAD;
begin
CURPAGE := NEWPAGE;
NEWPAGE := NEWPAGE+1;
if (M1VAL > 0) then
begin
SKIP(M1VAL-1);
PUTTL(HEADER, CURPAGE)
end;
SKIP(M2VAL);
LINENO := M1VAL+M2VAL+1
end;
{!putfoot.p!}
{ putfoot -- put out page footer }
procedure PUTFOOT;
begin
SKIP(M3VAL);
if (M4VAL > 0) then
begin
PUTTL(FOOTER, CURPAGE);
SKIP(M4VAL-1)
end
end;
{!puttl.p!}
{ puttl -- put out title line with optional page number }
procedure PUTTL(var BUF : STRINGZ;
PAGENO : Integer);
var
I : Integer;
begin
for I := 1 to LENGTHZ(BUF) do
if (BUF[I] = PAGENUM) then
PUTDEC(PAGENO, 1)
else
PUTC(BUF[I])
end;
{!gettl.p!}
{ gettl -- copy title from buf to ttl }
procedure GETTL(var BUF, TTL : STRINGZ);
var
I : Integer;
begin
I := 1; { skip command name }
while (not(BUF[I] in [BLANK, TAB, NEWLINE])) do
I := I+1;
SKIPBL(BUF, I); { find argument }
if (BUF[I] = SQUOTE) or (BUF[I] = DQUOTE) then
I := I+1; { strip leading quote }
SCOPY(BUF, I, TTL, 1)
end;
{!space.p!}
{ space -- space n lines or to bottom of page }
procedure SPACE(N : Integer);
begin
BREAKZ;
if (LINENO <= BOTTOM) then
begin
if (LINENO <= 0) then
PUTHEAD;
SKIP(MIN(N, BOTTOM+1-LINENO));
LINENO := LINENO+N;
if (LINENO > BOTTOM) then
PUTFOOT
end
end;
{!page.p!}
{ page -- get to top of new page }
procedure PAGE;
begin
BREAKZ;
if ((LINENO > 0) and
(LINENO <= BOTTOM)) then
begin
SKIP(BOTTOM+1-LINENO);
PUTFOOT
end;
LINENO := 0
end;
{!leadbl.p!}
{ leadbl -- delete leading blanks, set tival }
procedure LEADBL(var BUF : STRINGZ);
var
I, J : Integer;
begin
BREAKZ;
I := 1;
while (BUF[I] = BLANK) do { find 1st non-blank }
I := I+1;
if (BUF[I] <> NEWLINE) then
TIVAL := TIVAL+I-1;
for J := I to LENGTHZ(BUF)+1 do { move line to left }
BUF[J-I+1] := BUF[J]
end;
{!textz2.p!}
{ textz -- process text lines (interim version 2) }
procedure TEXTZ(var INBUF : STRINGZ);
var
WORDBUF : STRINGZ;
I : Integer;
begin
if ((INBUF[1] = BLANK) or
(INBUF[1] = NEWLINE)) then
LEADBL(INBUF); { move left, set tival }
if (INBUF[1] = NEWLINE) then { all blank line }
PUT(INBUF)
else if (not FILL) then { unfilled text }
PUT(INBUF)
else
begin { filled text }
I := 1;
repeat
I := GETWORD(INBUF, I, WORDBUF);
if (I > 0) then
PUTWORD(WORDBUF)
until (I = 0)
end
end;
{!putword1.p!}
{ putword -- put word in outbuf }
procedure PUTWORD(var WORDBUF : STRINGZ);
var
LAST, LLVAL, NEXTRA, W : Integer;
begin
W := WIDTH(WORDBUF);
LAST := LENGTHZ(WORDBUF)+OUTP+1; { new end of outbuf }
LLVAL := RMVAL-TIVAL-INVAL;
if ((OUTP > 0) and
((OUTW+W > LLVAL) or
(LAST >= MAXSTR))) then
begin
LAST := LAST-OUTP; { remember end of wordbuf }
BREAKZ { flush previous line }
end;
SCOPY(WORDBUF, 1, OUTBUF, OUTP+1);
OUTP := LAST;
OUTBUF[OUTP] := BLANK; { blank between words }
OUTW := OUTW+W+1; { 1 for blank }
OUTWDS := OUTWDS+1
end;
{!width.p!}
{ width -- compute width of character string }
function WIDTH(var BUF : STRINGZ) : Integer;
var
I, W : Integer;
begin
W := 0;
I := 1;
while (BUF[I] <> ENDSTR) do
begin
if (BUF[I] = BACKSPACE) then
W := W-1
else if (BUF[I] <> NEWLINE) then
W := W+1;
I := I+1
end;
WIDTH := W
end;
{!breakz.p!}
{ breakz -- end current filled line }
procedure BREAKZ;
begin
if (OUTP > 0) then
begin
OUTBUF[OUTP] := NEWLINE;
OUTBUF[OUTP+1] := ENDSTR;
PUT(OUTBUF)
end;
OUTP := 0;
OUTW := 0;
OUTWDS := 0
end;
{!putword.p!}
{ putword -- put word in outbuf, does margin justification }
procedure PUTWORD(var WORDBUF : STRINGZ);
var
LAST, LLVAL, NEXTRA, W : Integer;
begin
W := WIDTH(WORDBUF);
LAST := LENGTHZ(WORDBUF)+OUTP+1;
LLVAL := RMVAL-TIVAL-INVAL;
if ((OUTP > 0) and
((OUTW+W > LLVAL) or
(LAST >= MAXSTR))) then
begin
LAST := LAST-OUTP; { remember end of wordbuf }
NEXTRA := LLVAL-OUTW+1;
if ((NEXTRA > 0) and
(OUTWDS > 1)) then
begin
SPREAD(OUTBUF, OUTP, NEXTRA, OUTWDS);
OUTP := OUTP+NEXTRA
end;
BREAKZ { flush previous line }
end;
SCOPY(WORDBUF, 1, OUTBUF, OUTP+1);
OUTP := LAST;
OUTBUF[OUTP] := BLANK; { blank between words }
OUTW := OUTW+W+1; { 1 for blank }
OUTWDS := OUTWDS+1
end;
{!spread.p!}
{ spread -- spread words to justify right margin }
procedure SPREAD(var BUF : STRINGZ;
OUTP, NEXTRA, OUTWDS : Integer);
var
I, J, NB, NHOLES : Integer;
begin
if ((NEXTRA > 0) and
(OUTWDS > 1)) then
begin
DIR := 1-DIR; { reverse previous direction }
NHOLES := OUTWDS-1;
I := OUTP-1;
J := MIN(MAXSTR-2, I+NEXTRA); { room fore NEWLINE }
while (I < J) do
begin { end ENDSTR }
BUF[J] := BUF[I];
if (BUF[I] = BLANK) then
begin
if (DIR = 0) then
NB := (NEXTRA-1) div NHOLES+1
else NB := NEXTRA div NHOLES;
NEXTRA := NEXTRA-NB;
NHOLES := NHOLES-1;
while (NB > 0) do
begin
J := J-1;
BUF[J] := BLANK;
NB := NB-1
end
end;
I := I-1;
J := J-1
end
end
end;
{!center.p!}
{ center -- center a line by setting tival }
procedure CENTER(var BUF : STRINGZ);
begin
TIVAL := MAX((RMVAL+TIVAL-WIDTH(BUF)) div 2, 0)
end;
{!underln.p!}
{ underln -- underline a line }
procedure UNDERLN(var BUF : STRINGZ;
SIZE : Integer);
var
I, J : Integer;
TBUF : STRINGZ;
begin
J := 1; { expand into tbuf }
I := 1;
while ((BUF[I] <> NEWLINE) and
(J < SIZE-1)) do
begin
if (ISALPHANUM(BUF[I])) then
begin
TBUF[J] := UNDERLINE;
TBUF[J+1] := BACKSPACE;
J := J+2
end;
TBUF[J] := BUF[I];
J := J+1;
I := I+1
end;
TBUF[J] := NEWLINE;
TBUF[J+1] := ENDSTR;
SCOPY(TBUF, 1, BUF, 1) { copy it back to buf }
end;
{!textz.p!}
{ textz -- process text lines (final version) }
procedure TEXTZ(var INBUF : STRINGZ);
var
WORDBUF : STRINGZ;
I : Integer;
begin
if ((INBUF[1] = BLANK) or
(INBUF[1] = NEWLINE)) then
LEADBL(INBUF); { move left, set tival }
if (ULVAL > 0) then
begin { underlining }
UNDERLN(INBUF, MAXSTR);
ULVAL := ULVAL-1
end;
if (CEVAL > 0) then
begin { centering }
CENTER(INBUF);
PUT(INBUF);
CEVAL := CEVAL-1
end
else if (INBUF[1] = NEWLINE) then { all-blank line }
PUT(INBUF)
else if (not FILL) then { unfilled text }
PUT(INBUF)
else
begin { filled text }
I := 1;
repeat
I := GETWORD(INBUF, I, WORDBUF);
if (I > 0) then
PUTWORD(WORDBUF)
until (I = 0)
end
end;
{!format.p!}
{ format -- text formatter main program (final version) }
procedure FORMAT;
#include "fmtcons.p"
type
CMDTYPE = (BP, BR, CE, FI, FO, HE, IND, LS, NF, PL,
RM, SP, TI, UL, UNKNOWN);
var
{ page parameters }
CURPAGE : Integer; { current output page number; init=0 }
NEWPAGE : Integer; { next output page number; init=1 }
LINENO : Integer; { next line to be printed; init=0 }
PLVAL : Integer; { page length in lines; init=PAGELEN=66 }
M1VAL : Integer; { margin before and including header }
M2VAL : Integer; { margin after header }
M3VAL : Integer; { margin after last text line }
M4VAL : Integer; { bottom margin, including footer }
BOTTOM : Integer; { last line on page, =plval-m3val-m4val }
HEADER : STRINGZ; { top of page title; init=NEWLINE }
FOOTER : STRINGZ; { bottom of page title; init=NEWLINE }
{ global parameters }
FILL : Boolean; { fill if true; init=true }
LSVAL : Integer; { current line spacing; init=1 }
SPVAL : Integer; { # of lines to space }
INVAL : Integer; { current indent; >= 0; init=0 }
RMVAL : Integer; { right margin; init=PAGEWIDTH=60 }
TIVAL : Integer; { current temporary indent; init=0 }
CEVAL : Integer; { # of lines to center; init=0 }
ULVAL : Integer; { # of lines to underline; init=0 }
{ output area }
OUTP : Integer; { last char pos in outbuf; init=0 }
OUTW : Integer; { width of text in outbuf; init=0 }
OUTWDS : Integer; { number of words in outbuf; init=0 }
OUTBUF : STRINGZ; { lines to be filled collect here }
DIR : 0..1; { direction for blank padding }
INBUF : STRINGZ; { input line }
#include "fmtproc.p"
begin
INITFMT;
while (GETLINE(INBUF, STDIN, MAXSTR)) do
if (INBUF[1] = CMD) then
COMMAND(INBUF)
else
TEXTZ(INBUF);
PAGE
end;
{!initfmt.p!}
{ initfmt -- set format parameters to default values }
procedure INITFMT;
begin
FILL := True;
DIR := 0;
INVAL := 0;
RMVAL := PAGEWIDTH;
TIVAL := 0;
LSVAL := 1;
SPVAL := 0;
CEVAL := 0;
ULVAL := 0;
LINENO := 0;
CURPAGE := 0;
NEWPAGE := 1;
PLVAL := PAGELEN;
M1VAL := 3; M2VAL := 2; M3VAL := 2; M4VAL := 3;
BOTTOM := PLVAL-M3VAL-M4VAL;
HEADER[1] := NEWLINE; { initial titles }
HEADER[2] := ENDSTR;
FOOTER[1] := NEWLINE;
FOOTER[2] := ENDSTR;
OUTP := 0;
OUTW := 0;
OUTWDS := 0
end;
{!fmtcons.p!}
{ fmtcons -- constants for format }
const
CMD = PERIOD;
PAGENUM = SHARP;
PAGEWIDTH = 60;
PAGELEN = 66;
HUGE = 10000;
{!fmtproc.p!}
{ fmtproc -- procedures needed for format }
#include "skipbl.p"
#include "skip.p"
#include "getcmd.p"
#include "setparam.p"
#include "getval.p"
#include "gettl.p"
#include "puttl.p"
#include "puthead.p"
#include "putfoot.p"
#include "width.p"
#include "put.p"
#include "breakz.p"
#include "space.p"
#include "page.p"
#include "leadbl.p"
#include "spread.p"
#include "putword.p"
#include "getword.p"
#include "center.p"
#include "underln.p"
#include "initfmt.p"
#include "command.p"
#include "textz.p"
{!gettok.p!}
{ gettok -- get token for define }
function GETTOK(var TOKEN : STRINGZ;
TOKSIZE : Integer) : CHARACTER;
var
I : Integer;
DONE : Boolean;
begin
I := 1;
DONE := False;
while ((not DONE) and
(I < TOKSIZE)) do
if (ISALPHANUM(GETPBC(TOKEN[I]))) then
I := I+1
else
DONE := True;
if (I >= TOKSIZE) then
ERROR('define: token too long');
if (I > 1) then
begin { some alpha was seen }
PUTBACK(TOKEN[I]);
I := I-1
end;
{ else single non-alphanumeric }
TOKEN[I+1] := ENDSTR;
GETTOK := TOKEN[1]
end;
{!putback.p!}
{ putback -- push character back onto input }
procedure PUTBACK(C : CHARACTER);
begin
if (BP >= BUFSIZE) then
ERROR('too many characters pushed back');
BP := BP+1;
BUF[BP] := C
end;
{!getpbc.p!}
{ getpbc -- get a (possibly pushed back) character }
function GETPBC(var C : CHARACTER) : CHARACTER;
begin
if (BP > 0) then
C := BUF[BP]
else
begin
BP := 1;
BUF[BP] := GETC(C)
end;
if (C <> ENDFILE) then
BP := BP-1;
GETPBC := C
end;
{!pbstr.p!}
{ pbstr -- push string back onto input }
procedure PBSTR(var S : STRINGZ);
var
I : Integer;
begin
for I := LENGTHZ(S) downto 1 do
PUTBACK(S[I])
end;
{!define.p!}
{ define -- simple string replacement macro preprocessor }
procedure DEFINE;
#include "defcons.p"
#include "deftype.p"
#include "defvar.p"
DEFN : STRINGZ;
TOKEN : STRINGZ;
TOKTYPE : STTYPE; { type returned by lookup }
DEFNAME : STRINGZ; { value is 'defined' }
NULL : STRINGZ; { value is '' }
#include "defproc.p"
begin
NULL[1] := ENDSTR;
INITDEF;
INSTALL(DEFNAME, NULL, DEFTYPE);
while (GETTOK(TOKEN, MAXTOK) <> ENDFILE) do
if (not ISLETTER(TOKEN[1])) then
PUTSTR(TOKEN, STDOUT)
else if (not LOOKUP(TOKEN, DEFN, TOKTYPE)) then
PUTSTR(TOKEN, STDOUT) { undefined }
else if (TOKTYPE = DEFTYPE) then
begin { defs }
GETDEF(TOKEN, MAXTOK, DEFN, MAXDEF);
INSTALL(TOKEN, DEFN, MACTYPE)
end
else
PBSTR(DEFN) { push replacement onto input }
end;
{!isletter.p!}
{ isletter -- true if c is a letter of either case }
function ISLETTER(C : CHARACTER) : Boolean;
begin
ISLETTER := C in [Ord('a') ..Ord('z')]+[Ord('A') ..Ord('Z')]
end;
{!getdef.p!}
{ getdef -- get name and definiations }
procedure GETDEF(var TOKEN : STRINGZ;
TOKSIZE : Integer;
var DEFN : STRINGZ;
DEFSIZE : Integer);
var
I, NLPAR : Integer;
C : CHARACTER;
begin
TOKEN[1] := ENDSTR; { in case of bad input }
DEFN[1] := ENDSTR;
if (GETPBC(C) <> LPAREN) then
MESSAGE('define: missing left paren')
else if (not ISLETTER(GETTOK(TOKEN, TOKSIZE))) then
MESSAGE('define : non-alphanumeric name')
else if (GETPBC(C) <> COMMA) then
MESSAGE('define: missing comma in define')
else
begin { got '(name,'' so far }
while (GETPBC(C) = BLANK) do ; { skip leading blanks }
PUTBACK(C); { went one too far }
NLPAR := 0;
I := 1;
while (NLPAR >= 0) do
begin
if (I >= DEFSIZE) then
ERROR('define: definition too long')
else if (GETPBC(DEFN[I]) = ENDFILE) then
ERROR('define: missing right paren')
else if (DEFN[I] = LPAREN) then
NLPAR := NLPAR+1
else if (DEFN[I] = RPAREN) then
NLPAR := NLPAR-1;
{ else normal character in defn[i] }
I := I+1;
end;
DEFN[I-1] := ENDSTR
end
end;
{!initdef.p!}
{ initdef -- initialize variables for define }
procedure INITDEF;
begin
{ setstring(defname, 'define'); }
DEFNAME[1] := Ord('d');
DEFNAME[2] := Ord('e');
DEFNAME[3] := Ord('f');
DEFNAME[4] := Ord('i');
DEFNAME[5] := Ord('n');
DEFNAME[6] := Ord('e');
DEFNAME[7] := ENDSTR;
BP := 0; { pushback buffer pointer }
INITHASH;
end;
{!deftype.p!}
{ deftype -- type definitions for define }
type
CHARPOS = 1..MAXCHARS;
CHARBUF = array[1..MAXCHARS] of CHARACTER;
STTYPE = (DEFTYPE, MACTYPE); { symbol table types }
NDPTR = ^NDBLOCK; { pointer to a name-defn block }
NDBLOCK = record { name-defn block }
NAME : CHARPOS;
DEFN : CHARPOS;
KIND : STTYPE;
NEXTPTR : NDPTR
end;
{!defvar.p!}
{ defvar -- var declarations for define }
var
HASHTAB : array[1..HASHSIZE] of NDPTR;
NDTABLE : CHARBUF;
NEXTTAB : CHARPOS; { first free position in ndtable }
BUF : array[1..BUFSIZE] of CHARACTER; { for pushback }
BP : 0..BUFSIZE; { next available character; init=0 }
{!inithash.p!}
{ inithash -- initialize hash table to nil }
procedure INITHASH;
var
I : 1..HASHSIZE;
begin
NEXTTAB := 1; { first free slot in table }
for I := 1 to HASHSIZE do
HASHTAB[I] := nil
end;
{!lookup.p!}
{ lookup -- locate name, get defn and type from table }
function LOOKUP(var NAME, DEFN : STRINGZ;
var T : STTYPE) : Boolean;
var
P : NDPTR;
begin
P := HASHFIND(NAME);
if (P = nil) then
LOOKUP := False
else
begin
LOOKUP := True;
CSCOPY(NDTABLE, P^.DEFN, DEFN);
T := P^.KIND
end
end;
{!hashfind.p!}
{ hashfind -- find name in hash table }
function HASHFIND(var NAME : STRINGZ) : NDPTR;
var
P : NDPTR;
TEMPNAME : STRINGZ;
FOUND : Boolean;
begin
FOUND := False;
P := HASHTAB[HASH(NAME)];
while ((not FOUND) and
(P <> nil)) do
begin
CSCOPY(NDTABLE, P^.NAME, TEMPNAME);
if (EQUAL(NAME, TEMPNAME)) then
FOUND := True
else
P := P^.NEXTPTR
end;
HASHFIND := P
end;
{!hash.p!}
{ hash -- compute hash function of a name }
function HASH(var NAME : STRINGZ) : Integer;
var
I, H : Integer;
begin
H := 0;
for I := 1 to LENGTHZ(NAME) do
H := (3*H+NAME[I]) mod HASHSIZE;
HASH := H+1
end;
{!install.p!}
{ install -- add name, definition and type to table }
procedure INSTALL(var NAME, DEFN : STRINGZ;
T : STTYPE);
var
H, DLEN, NLEN : Integer;
P : NDPTR;
begin
NLEN := LENGTHZ(NAME)+1; { 1 for ENDSTR }
DLEN := LENGTHZ(DEFN)+1;
if (NEXTTAB+NLEN+DLEN > MAXCHARS) then
begin
PUTSTR(NAME, STDERR);
ERROR(': too many definitions')
end
else
begin { put it at front of chain }
H := HASH(NAME);
New(P);
P^.NEXTPTR := HASHTAB[H];
HASHTAB[H] := P;
P^.NAME := NEXTTAB;
SCCOPY(NAME, NDTABLE, NEXTTAB);
NEXTTAB := NEXTTAB+NLEN;
P^.DEFN := NEXTTAB;
SCCOPY(DEFN, NDTABLE, NEXTTAB);
NEXTTAB := NEXTTAB+DLEN;
P^.KIND := T
end
end;
{!defcons.p!}
{ defcons -- const declarations for define }
const
BUFSIZE = 500; { size of pushback buffer }
MAXCHARS = 5000; { size of name-defn table }
MAXDEF = MAXSTR; { max chars in a defn }
MAXTOK = MAXSTR; { max chars in a token }
HASHSIZE = 53; { size of hash table }
{!defproc.p!}
{ defproc -- procedures needed by define }
#include "cscopy.p"
#include "sccopy.p"
#include "putback.p"
#include "getpbc.p"
#include "pbstr.p"
#include "gettok.p"
#include "getdef.p"
#include "inithash.p"
#include "hash.p"
#include "hashfind.p"
#include "install.p"
#include "lookup.p"
#include "initdef.p"
{!macro.p!}
{ macro -- expand macros with arguments }
procedure MACRO;
#include "maccons.p"
#include "mactype.p"
#include "macvar.p"
DEFN : STRINGZ;
TOKEN : STRINGZ;
TOKTYPE : STTYPE;
T : CHARACTER;
NLPAR : Integer;
#include "macproc.p"
begin
INITMACRO;
INSTALL(DEFNAME, NULL, DEFTYPE);
INSTALL(EXPRNAME, NULL, EXPRTYPE);
INSTALL(SUBNAME, NULL, SUBTYPE);
INSTALL(IFNAME, NULL, IFTYPE);
INSTALL(LENNAME, NULL, LENTYPE);
INSTALL(CHQNAME, NULL, CHQTYPE);
CP := 0;
AP := 1;
EP := 1;
while (GETTOK(TOKEN, MAXTOK) <> ENDFILE) do
if (ISLETTER(TOKEN[1])) then
begin
if (not LOOKUP(TOKEN, DEFN, TOKTYPE)) then
PUTTOK(TOKEN)
else
begin { defined; put it in eval stack }
CP := CP+1;
if (CP > CALLSIZE) then
ERROR('macro: call stack overflow');
CALLSTK[CP] := AP;
TYPESTK[CP] := TOKTYPE;
AP := PUSH(EP, ARGSTK, AP);
PUTTOK(DEFN); { push definition }
PUTCHR(ENDSTR);
AP := PUSH(EP, ARGSTK, AP);
PUTTOK(TOKEN); { stack name }
PUTCHR(ENDSTR);
AP := PUSH(EP,ARGSTK,AP);
T := GETTOK(TOKEN,MAXTOK); { peek at next }
PBSTR(TOKEN);
if (T <> LPAREN) then
begin { add () }
PUTBACK(RPAREN);
PUTBACK(LPAREN)
end;
PLEV[CP] := 0
end
end
else if (TOKEN[1] = LQUOTE) then
begin { strip quotes }
NLPAR := 1;
repeat
T := GETTOK(TOKEN, MAXTOK);
if (T = RQUOTE) then
NLPAR := NLPAR-1
else if (T = LQUOTE) then
NLPAR := NLPAR+1
else if (T = ENDFILE) then
ERROR('macro: missing right quote');
if (NLPAR > 0) then
PUTTOK(TOKEN)
until (NLPAR = 0)
end
else if (CP = 0) then { not in a macro at all }
PUTTOK(TOKEN)
else if (TOKEN[1] = LPAREN) then
begin
if (PLEV[CP] > 0) then
PUTTOK(TOKEN);
PLEV[CP] := PLEV[CP]+1
end
else if (TOKEN[1] = RPAREN) then
begin
PLEV[CP] := PLEV[CP]-1;
if (PLEV[CP] > 0) then
PUTTOK(TOKEN)
else
begin { end of argument list }
PUTCHR(ENDSTR);
EVAL(ARGSTK, TYPESTK[CP], CALLSTK[CP], AP-1);
AP := CALLSTK[CP]; { pop eval stack }
EP := ARGSTK[AP];
CP := CP-1
end
end
else if ((TOKEN[1] = COMMA) and
(PLEV[CP] = 1)) then
begin
PUTCHR(ENDSTR); { new argument }
AP := PUSH(EP, ARGSTK, AP)
end
else
PUTTOK(TOKEN); { just stack it }
if (CP <> 0) then
ERROR('macro: unexpected end of input')
end;
{!puttok.p!}
{ puttok -- put token on output or evaluation stack }
procedure PUTTOK(var S : STRINGZ);
var
I : Integer;
begin
I := 1;
while (S[I] <> ENDSTR) do
begin
PUTCHR(S[I]);
I := I+1
end
end;
{!putchr.p!}
{ putchr -- put single char on output or evaluation stack }
procedure PUTCHR(C : CHARACTER);
begin
if (CP <= 0) then
PUTC(C)
else
begin
if (EP > EVALSIZE) then
ERROR('macro: evaluation stack overflow');
EVALSTK[EP] := C;
EP := EP+1
end
end;
{!push.p!}
{ push -- push ep onto argstk, return new position ap }
function PUSH(EP : Integer;
var ARGSTK : POSBUF;
AP : Integer) : Integer;
begin
if (AP > ARGSIZE) then
ERROR('macro: argument stack overflow');
ARGSTK[AP] := EP;
PUSH := AP+1
end;
{!eval.p!}
{ eval -- expand args i..j: do built-in or push back defn }
procedure EVAL(var ARGSTK : POSBUF;
TD : STTYPE;
I, J : Integer);
var
ARGNO, K, T : Integer;
TEMP : STRINGZ;
begin
T := ARGSTK[I];
if (TD = DEFTYPE) then
DODEF(ARGSTK, I, J)
else if (TD = EXPRTYPE) then
DOEXPR(ARGSTK, I, J)
else if (TD = SUBTYPE) then
DOSUB(ARGSTK, I, J)
else if (TD = IFTYPE) then
DOIF(ARGSTK, I, J)
else if (TD = LENTYPE) then
DOLEN(ARGSTK, I, J)
else if (TD = CHQTYPE) then
DOCHQ(ARGSTK, I, J)
else
begin
K := T;
while (EVALSTK[K] <> ENDSTR) do
K := K+1;
K := K-1; { last character of defn }
while (K > T) do
begin
if (EVALSTK[K-1] <> ARGFLAG) then
PUTBACK(EVALSTK[K])
else
begin
ARGNO := Ord(EVALSTK[K])-Ord('0');
if ((ARGNO >= 0) and
(ARGNO < J-I)) then
begin
CSCOPY(EVALSTK, ARGSTK[I+ARGNO+1], TEMP);
PBSTR(TEMP)
end;
K := K-1 { skip over $ }
end;
K := K-1
end;
if (K = T) then { do last character }
PUTBACK(EVALSTK[K])
end
end;
{!dodef.p!}
{ dodef -- install definitions in table }
procedure DODEF(var ARGSTK : POSBUF;
I, J : Integer);
var
TEMP1, TEMP2 : STRINGZ;
begin
if (J-I > 2) then
begin
CSCOPY(EVALSTK, ARGSTK[I+2], TEMP1);
CSCOPY(EVALSTK, ARGSTK[I+3], TEMP2);
INSTALL(TEMP1, TEMP2, MACTYPE)
end
end;
{!doif.p!}
{ doif -- select one of two arguments }
procedure DOIF(var ARGSTK : POSBUF;
I, J : Integer);
var
TEMP1, TEMP2, TEMP3 : STRINGZ;
begin
if (J-I >= 4) then
begin
CSCOPY(EVALSTK, ARGSTK[I+2], TEMP1);
CSCOPY(EVALSTK, ARGSTK[I+3], TEMP2);
if (EQUAL(TEMP1, TEMP2)) then
CSCOPY(EVALSTK, ARGSTK[I+4], TEMP3)
else if (J-I >= 5) then
CSCOPY(EVALSTK, ARGSTK[I+5], TEMP3)
else
TEMP3[1] := ENDSTR;
PBSTR(TEMP3)
end
end;
{!doexpr.p!}
{ doexpr -- evaluate arithmetic expressions }
procedure DOEXPR(var ARGSTK : POSBUF;
I, J : Integer);
var
TEMP : STRINGZ;
JUNK : Integer;
begin
CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
JUNK := 1;
PBNUM(EXPR(TEMP, JUNK))
end;
{!pbnum.p!}
{ pbnum -- convert number to string, push back on input }
procedure PBNUM(N : Integer);
var
TEMP : STRINGZ;
JUNK : Integer;
begin
JUNK := ITOC(N, TEMP, 1);
PBSTR(TEMP)
end;
{!expr.p!}
{ expr -- recursive expression evaluation }
function EXPR(var S : STRINGZ;
var I : Integer) : Integer;
var
V : Integer;
T : CHARACTER;
#include "gnbchar.p"
#include "term.p"
begin
V := TERM(S, I);
T := GNBCHAR(S, I);
while (T in [PLUS, MINUS]) do
begin
I := I+1;
if (T = PLUS) then
V := V+TERM(S, I)
else
V := V-TERM(S, I);
T := GNBCHAR(S, I)
end;
EXPR := V
end;
{!term.p!}
{ term -- evaluate term of arithmetic expression }
function TERM(var S : STRINGZ;
var I : Integer) : Integer;
var
V : Integer;
T : CHARACTER;
#include "factor.p"
begin
V := FACTOR(S, I);
T := GNBCHAR(S, I);
while (T in [STAR, SLASH, PERCENT]) do
begin
I := I+1;
case T of
STAR :
V := V*FACTOR(S, I);
SLASH :
V := V div FACTOR(S, I);
PERCENT :
V := V mod FACTOR(S, I)
end;
T := GNBCHAR(S, I)
end;
TERM := V
end;
{!factor.p!}
{ factor -- evaluate factor of arithmetic expression }
function FACTOR(var S : STRINGZ;
var I : Integer) : Integer;
begin
if (GNBCHAR(S, I) = LPAREN) then
begin
I := I+1;
FACTOR := EXPR(S, I);
if (GNBCHAR(S, I) = RPAREN) then
I := I+1
else
WriteLn('macro: missing paren in expr')
end
else
FACTOR := CTOI(S, I)
end;
{!gnbchar.p!}
{ gnbchar -- get next non-blank character }
function GNBCHAR(var S : STRINGZ;
var I : Integer) : CHARACTER;
begin
while (S[I] in [BLANK, TAB, NEWLINE]) do
I := I+1;
GNBCHAR := S[I]
end;
{!dolen.p!}
{ dolen -- return length of argument }
procedure DOLEN(var ARGSTK : POSBUF;
I, J : Integer);
var
TEMP : STRINGZ;
begin
if (J-I > 1) then
begin
CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
PBNUM(LENGTHZ(TEMP))
end
else
PBNUM(0)
end;
{!dosub.p!}
{ dosub -- select substring }
procedure DOSUB(var ARGSTK : POSBUF;
I, J : Integer);
var
AP, FC, K, NC : Integer;
TEMP1, TEMP2 : STRINGZ;
begin
if (J-I >= 3) then
begin
if (J-I < 4) then
NC := MAXTOK
else
begin
CSCOPY(EVALSTK, ARGSTK[I+4], TEMP1);
K := 1;
NC := EXPR(TEMP1, K)
end;
CSCOPY(EVALSTK, ARGSTK[I+3], TEMP1); { origin }
AP := ARGSTK[I+2]; { target string }
K := 1;
FC := AP+EXPR(TEMP1, K)-1; { first char }
CSCOPY(EVALSTK, AP, TEMP2);
if ((FC >= AP) and
(FC < AP+LENGTHZ(TEMP2))) then
begin
CSCOPY(EVALSTK, FC, TEMP1);
for K := FC+MIN(NC, LENGTHZ(TEMP1))-1 downto FC do
PUTBACK(EVALSTK[K])
end
end
end;
{!dochq.p!}
{ dochq -- change quote characters }
procedure DOCHQ(var ARGSTK : POSBUF;
I, J : Integer);
var
TEMP : STRINGZ;
N : Integer;
begin
CSCOPY(EVALSTK, ARGSTK[I+2], TEMP);
N := LENGTHZ(TEMP);
if (N <= 0) then
begin
LQUOTE := Ord(GRAVE);
RQUOTE := Ord(ACUTE)
end
else if (N = 1) then
begin
LQUOTE := TEMP[1];
RQUOTE := LQUOTE
end
else
begin
LQUOTE := TEMP[1];
RQUOTE := TEMP[2]
end
end;
{!mactype.p!}
{ mactype -- type declarations for macro }
type
CHARPOS = 1..MAXCHARS;
CHARBUF = array[1..MAXCHARS] of CHARACTER;
POSBUF = array[1..MAXPOS] of CHARPOS;
POSZ = 0..MAXPOS;
STTYPE = (DEFTYPE, MACTYPE, IFTYPE, SUBTYPE,
EXPRTYPE, LENTYPE, CHQTYPE); { symbol table types }
NDPTR = ^NDBLOCK;
NDBLOCK = record
NAME : CHARPOS;
DEFN : CHARPOS;
KIND : STTYPE;
NEXTPTR : NDPTR
end;
{!maccons.p!}
{ maccons -- const declarations for macro }
const
BUFSIZE = 1000; { size of pushback buffer }
MAXCHARS = 5000; { size of name-defn table }
MAXPOS = 500; { size of position arrays }
CALLSIZE = MAXPOS;
ARGSIZE = MAXPOS;
EVALSIZE = MAXCHARS;
MAXDEF = MAXSTR; { max chars in a defn }
MAXTOK = MAXSTR; { max chars in a token }
HASHSIZE = 53; { size of hash table }
ARGFLAG = DOLLAR; { macro invocation character }
{!macvar.p!}
{ macvar -- var declarations for macro }
var
BUF : array[1..BUFSIZE] of CHARACTER; { for pushback }
BP : 0..BUFSIZE; { next available character; init=0 }
HASHTAB : array[1..HASHSIZE] of NDPTR;
NDTABLE : CHARBUF;
NEXTTAB : CHARPOS; { first free position in ndtable }
CALLSTK : POSBUF; { call stack }
CP : POSZ; { current call stack position }
TYPESTK : array[1..CALLSIZE] of STTYPE; { type }
PLEV : array[1..CALLSIZE] of Integer; { paren level }
ARGSTK : POSBUF; { argument stack for this call }
AP : POSZ; { current argument position }
EVALSTK : CHARBUF; { evaluation stack }
EP : CHARPOS; { first character unused in evalstk }
{ built-ins: }
DEFNAME : STRINGZ; { value is 'define' }
EXPRNAME : STRINGZ; { value is 'expr' }
SUBNAME : STRINGZ; { value is 'substr' }
IFNAME : STRINGZ; { value is 'ifelse' }
LENNAME : STRINGZ; { value is 'len' }
CHQNAME : STRINGZ; { vlaue is 'changeq' }
NULL : STRINGZ; { value is '' }
LQUOTE : CHARACTER; { left quote character }
RQUOTE : CHARACTER; { right quote character }
{!initmacr.p!}
{ initmacro -- initialize variables for macro }
procedure INITMACRO;
begin
NULL[1] := ENDSTR;
{ setstring(defname, 'define'); }
DEFNAME[1] := Ord('d');
DEFNAME[2] := Ord('e');
DEFNAME[3] := Ord('f');
DEFNAME[4] := Ord('i');
DEFNAME[5] := Ord('n');
DEFNAME[6] := Ord('e');
DEFNAME[7] := ENDSTR;
{ setstring(subname, 'substr'); }
SUBNAME[1] := Ord('s');
SUBNAME[2] := Ord('u');
SUBNAME[3] := Ord('b');
SUBNAME[4] := Ord('s');
SUBNAME[5] := Ord('t');
SUBNAME[6] := Ord('r');
SUBNAME[7] := ENDSTR;
{ setstring(exprname, 'expr'); }
EXPRNAME[1] := Ord('e');
EXPRNAME[2] := Ord('x');
EXPRNAME[3] := Ord('p');
EXPRNAME[4] := Ord('r');
EXPRNAME[5] := ENDSTR;
{ setstring(ifname, 'ifelse'); }
IFNAME[1] := Ord('i');
IFNAME[2] := Ord('f');
IFNAME[3] := Ord('e');
IFNAME[4] := Ord('l');
IFNAME[5] := Ord('s');
IFNAME[6] := Ord('e');
IFNAME[7] := ENDSTR;
{ setstring(lenname, 'len'); }
LENNAME[1] := Ord('l');
LENNAME[2] := Ord('e');
LENNAME[3] := Ord('n');
LENNAME[4] := ENDSTR;
{ setstring(chqname, 'changeq'); }
CHQNAME[1] := Ord('c');
CHQNAME[2] := Ord('h');
CHQNAME[3] := Ord('a');
CHQNAME[4] := Ord('n');
CHQNAME[5] := Ord('g');
CHQNAME[6] := Ord('e');
CHQNAME[7] := Ord('q');
CHQNAME[8] := ENDSTR;
BP := 0; { pushback buffer pointer }
INITHASH;
LQUOTE := Ord(GRAVE);
RQUOTE := Ord(ACUTE)
end;
{!macproc.p!}
{ macproc -- procedures for macro program }
#include "inithash.p"
#include "initmacr.p"
#include "hash.p"
#include "sccopy.p"
#include "install.p"
#include "getpbc.p"
#include "putback.p"
#include "gettok.p"
#include "cscopy.p"
#include "hashfind.p"
#include "lookup.p"
#include "putchr.p"
#include "puttok.p"
#include "push.p"
#include "pbstr.p"
#include "dodef.p"
#include "pbnum.p"
#include "expr.p"
#include "doexpr.p"
#include "dosub.p"
#include "doif.p"
#include "dolen.p"
#include "dochq.p"
#include "eval.p"
{!getc.p!}
{ getc -- (TP7) get one character from standard input }
function GETC(var C : CHARACTER) : CHARACTER;
var
CH : Char;
begin
if (Eof) then
C := ENDFILE
else if (Eoln) then
begin
ReadLn;
C := NEWLINE;
end
else
begin
Read(CH);
C := Ord(CH);
end;
GETC := C;
end;
{!putc.p!}
{ putc -- (TP7) put one character on standard output }
procedure PUTC(C : CHARACTER);
begin
if (C = NEWLINE) then
WriteLn
else
Write(Chr(C));
end;
{!prims.p!}
{ prims -- (TP7) primitive functions and procedures }
#include "initio.p"
#include "open.p"
#include "create.p"
#include "getc.p"
#include "getcf.p"
#include "getline.p"
#include "putc.p"
#include "putcf.p"
#include "putstr.p"
#include "closez.p"
#include "remove.p"
#include "getarg.p"
#include "nargs.p"
{!utility.p!}
{ utility -- generally useful function and procedures }
#include "addstr.p"
#include "equal.p"
#include "esc.p"
#include "indexz.p"
#include "isalnum.p"
#include "isdigit.p"
#include "isletter.p"
#include "islower.p"
#include "isupper.p"
#include "itoc.p"
#include "lengthz.p"
#include "max.p"
#include "min.p"
#include "scopy.p"
#include "ctoi.p"
#include "fcopy.p"
#include "mustcrea.p"
#include "mustopen.p"
#include "putdec.p"
{!islower.p!}
{ islower -- true if c is lower case letter }
function ISLOWER(C : CHARACTER) : Boolean;
begin
ISLOWER := C in [Ord('a') ..Ord('z')]
end;
{!globdefs.p!}
{ globdefs -- global constants, types and variables }
const
{ standard file descriptors, subscripts in open, etc. }
STDIN = 1; { these are not to be changed }
STDOUT = 2;
STDERR = 3;
{ other io-related stuff }
IOERROR = 0; { status values for open files }
IOAVAIL = 1;
IOREAD = 2;
IOWRITE = 3;
MAXOPEN = 10; { maximum number of open files }
{ universal manifest constants }
ENDFILE = 255;
ENDSTR = 0; { null-terminated stringzs }
MAXSTR = 100; { longest possible stringz }
{ ascii character set in decimal }
BACKSPACE = 8;
TAB = 9;
NEWLINE = 10; { line feed }
BLANK = Ord(' ');
EXCLAM = Ord('!');
DQUOTE = Ord('"');
SHARP = Ord('#');
DOLLAR = Ord('$');
PERCENT = Ord('%');
AMPER = Ord('&');
SQUOTE = Ord('''');
ACUTE = SQUOTE;
LPAREN = Ord('(');
RPAREN = Ord(')');
STAR = Ord('*');
PLUS = Ord('+');
COMMA = Ord(',');
MINUS = Ord('-');
DASH = MINUS;
PERIOD = Ord('.');
SLASH = Ord('/');
COLON = Ord(':');
SEMICOL = Ord(';');
LESS = Ord('<');
EQUALS = Ord('=');
GREATER = Ord('>');
QUESTION = Ord('?');
ATSIGN = Ord('@');
LBRACK = Ord('[');
BACKSLASH = Ord('\');
RBRACK = Ord(']');
CARET = Ord('^');
UNDERLINE = Ord('_');
GRAVE = Ord('`');
LBRACE = Ord('{');
BAR = Ord('|');
RBRACE = Ord('}');
TILDE = Ord('~');
type
CHARACTER = Byte; { byte-sized. ascii + other stuff }
STRINGZ = array[1..MAXSTR] of CHARACTER;
FILEDESC = IOERROR..MAXOPEN;
IOBLOCK = record { to keep track of open files }
FILEVAR : Text;
MODE : IOERROR..IOWRITE;
end;
var
OPENLIST : array[1..MAXOPEN] of IOBLOCK; { open files }
{!initio.p!}
{ initio -- (TP7) initialize open file list }
procedure INITIO;
var
INDEX : Integer;
begin
OPENLIST[STDIN].MODE := IOREAD;
OPENLIST[STDOUT].MODE := IOWRITE;
OPENLIST[STDERR].MODE := IOWRITE;
{ connect STDERR to user's terminal ... }
Assign(OPENLIST[STDERR].FILEVAR, '');
Rewrite(OPENLIST[STDERR].FILEVAR);
for INDEX := STDERR+1 to MAXOPEN do
OPENLIST[INDEX].MODE := IOAVAIL;
end;
{!open.p!}
{ open -- (TP7) make a file available for input or output }
function OPEN(NAME : STRINGZ;
MODE : Integer) : FILEDESC;
var
FILE_NAME : String[MAXSTR];
INDEX : Integer;
FOUND : Boolean;
begin
OPEN := IOERROR;
if ((MODE = IOREAD) or
(MODE = IOWRITE)) then
begin
INDEX := 1;
while (NAME[INDEX] <> ENDSTR) do
begin
FILE_NAME[INDEX] := Chr(NAME[INDEX]);
Inc(INDEX);
end;
FILE_NAME[0] := Chr(INDEX-1);
{ find a free slot in openlist }
FOUND := False;
INDEX := 1;
while ((INDEX <= MAXOPEN) and
(not FOUND)) do
begin
if (OPENLIST[INDEX].MODE = IOAVAIL) then
begin
OPENLIST[INDEX].MODE := MODE;
Assign(OPENLIST[INDEX].FILEVAR, FILE_NAME);
{$I-}
if (MODE = IOREAD) then
Reset(OPENLIST[INDEX].FILEVAR)
else
Rewrite(OPENLIST[INDEX].FILEVAR);
{$I+}
if (IoResult = 0) then
OPEN := INDEX;
FOUND := True;
end;
Inc(INDEX);
end;
end;
end;
{!create.p!}
{ create -- (TP7) make a new instance of a file available }
function CREATE(NAME : STRINGZ;
MODE : Integer) : FILEDESC;
var
FILE_NAME : String[MAXSTR];
INDEX : Integer;
FOUND : Boolean;
begin
CREATE := IOERROR;
if (MODE = IOWRITE) then
begin
INDEX := 1;
while (NAME[INDEX] <> ENDSTR) do
begin
FILE_NAME[INDEX] := Chr(NAME[INDEX]);
Inc(INDEX);
end;
FILE_NAME[0] := Chr(INDEX-1);
{ find a free slot in openlist }
FOUND := False;
INDEX := 1;
while ((INDEX <= MAXOPEN) and
(not FOUND)) do
begin
if (OPENLIST[INDEX].MODE = IOAVAIL) then
begin
OPENLIST[INDEX].MODE := MODE;
Assign(OPENLIST[INDEX].FILEVAR, FILE_NAME);
{$I-}
Rewrite(OPENLIST[INDEX].FILEVAR);
{$I+}
if (IoResult = 0) then
CREATE := INDEX;
FOUND := True;
end;
Inc(INDEX);
end;
end;
end;
{!closez.p!}
{ closez -- (TP7) close a file and release slot }
procedure CLOSEZ(FD : FILEDESC);
begin
if ((FD > STDERR) and
(FD <= MAXOPEN)) then
begin
Close(OPENLIST[FD].FILEVAR);
OPENLIST[FD].MODE := IOAVAIL;
end;
end;
{!remove.p!}
{ remove -- (TP7) remove a file }
procedure REMOVE(NAME : STRINGZ);
var
INDEX : Integer;
FILE_NAME : String[MAXSTR];
FILE_VAR : file;
begin
INDEX := 1;
while (NAME[INDEX] <> ENDSTR) do
begin
FILE_NAME[INDEX] := Chr(NAME[INDEX]);
Inc(INDEX);
end;
FILE_NAME[0] := Chr(INDEX-1);
{ make sure file exists before removing it }
Assign(FILE_VAR, FILE_NAME);
Rewrite(FILE_VAR);
Close(FILE_VAR);
Erase(FILE_VAR);
end;
{!getline.p!}
{ getline -- (TP7) get one line of text from a file }
function GETLINE(var S : STRINGZ;
FD : FILEDESC;
MAXSIZE : Integer) : Boolean;
var
I : Integer;
C : CHARACTER;
begin
I := 1;
repeat
S[I] := GETCF(C, FD);
I := I+1;
until ((C = ENDFILE) or
(C = NEWLINE) or
(I >= MAXSIZE));
if (C = ENDFILE) then { went one too far }
I := I-1;
S[I] := ENDSTR;
GETLINE := (C <> ENDFILE);
end;
{!putstr.p!}
{ putstr -- (TP7) put stringz in a file }
procedure PUTSTR(var S : STRINGZ;
FD : FILEDESC);
var
I : Integer;
begin
I := 1;
while (S[I] <> ENDSTR) do
begin
PUTCF(S[I], FD);
I := I+1;
end;
end;
{!getcf.p!}
{ getcf -- (TP7) get one character from a file }
function GETCF(var C : CHARACTER;
FD : FILEDESC) : CHARACTER;
var
CH : Char;
begin
if (FD = STDIN) then
GETCF := GETC(C)
else if Eof(OPENLIST[FD].FILEVAR) then
C := ENDFILE
else if Eoln(OPENLIST[FD].FILEVAR) then
begin
ReadLn(OPENLIST[FD].FILEVAR);
C := NEWLINE;
end
else
begin
Read(OPENLIST[FD].FILEVAR, CH);
C := Ord(CH);
end;
GETCF := C;
end;
{!putcf.p!}
{ putcf -- (TP7) put a single character in a file }
procedure PUTCF(C : CHARACTER;
FD : FILEDESC);
begin
if (FD = STDOUT) then
PUTC(C)
else if (C = NEWLINE) then
WriteLn(OPENLIST[FD].FILEVAR)
else
Write(OPENLIST[FD].FILEVAR, Chr(C));
end;
{!nargs.p!}
{ nargs -- (TP7) return number of arguments }
function NARGS : Integer;
begin
if (NARG = -1) then
PARSE_ARG;
NARGS := NARG;
end;
{!getarg.p!}
{ getarg -- (TP7) get n-th command line argument into s }
function GETARG(N : Integer;
var S : STRINGZ;
MAXSIZE : Integer) : Boolean;
var
START, FINISH : Integer;
SOURCE, DESTINATION, LEN, COUNT : Integer;
begin
if (NARG = -1) then
PARSE_ARG;
if ((N < 1) or
(NARG < N)) then
GETARG := False
else
begin
START := ARGS[N, 1];
FINISH := ARGS[N, 2];
LEN := FINISH-START+1;
if (MAXSIZE < LEN) then
LEN := MAXSIZE;
if (LEN >= 1) then
begin
DESTINATION := 1;
SOURCE := START;
COUNT := LEN;
repeat
S[DESTINATION] := Ord(CMD_TAIL[SOURCE]);
Inc(DESTINATION);
Inc(SOURCE);
Dec(COUNT);
until (COUNT = 0);
end;
S[LEN+1] := ENDSTR;
GETARG := True;
end;
end;
{!seekz.p!}
{ seekz -- position file access pointer }
procedure SEEKZ(RECNO : Integer;
FD : FILEDESC);
var
JUNK : Boolean;
TEMP : STRINGZ;
begin
if (RECNO < RECIN) then
begin
CLOSEZ(FD);
{ cheat: open scratch file by name }
FD := MUSTOPEN(EDITTEMP, IOREAD);
RECIN := 1;
end;
while (RECIN < RECNO) do
begin
JUNK := GETLINE(TEMP, FD, MAXSTR);
RECIN := RECIN+1
end
end;
{!error.p!}
{ error -- (TP7) print a message and exit program }
procedure ERROR(S : String);
begin
WriteLn;
WriteLn(S);
Halt(0);
end;
{!message.p!}
{ message -- (TP7) print a message and continue }
procedure MESSAGE(S : String);
begin
WriteLn(S);
end;
{!globdefs.i!}
{$I COMPILER.INC}
#include "header.p"
unit GLOBDEFS;
interface
#include "globdefs.p"
implementation
end.
{!prims.i!}
{$I COMPILER.INC}
#include "header.p"
unit PRIMS;
interface
uses GLOBDEFS;
procedure ERROR(S : String);
procedure MESSAGE(S : String);
procedure INITIO;
function OPEN(NAME : STRINGZ;
MODE : Integer) : FILEDESC;
function CREATE(NAME : STRINGZ;
MODE : Integer) : FILEDESC;
function GETC(var C : CHARACTER) : CHARACTER;
function GETCF(var C : CHARACTER;
FD : FILEDESC) : CHARACTER;
function GETLINE(var S : STRINGZ;
FD : FILEDESC;
MAXSIZE : Integer) : Boolean;
procedure PUTC(C : CHARACTER);
procedure PUTCF(C : CHARACTER;
FD : FILEDESC);
procedure PUTSTR(var S : STRINGZ;
FD : FILEDESC);
procedure CLOSEZ(FD : FILEDESC);
procedure REMOVE(NAME : STRINGZ);
function GETARG(N : Integer;
var S : STRINGZ;
MAXSIZE : Integer) : Boolean;
function NARGS : Integer;
implementation
{ TP7 command line argument declarations }
const
MAX_ARGS = 64;
NARG : Integer = -1;
var
ARGS : array[1..MAX_ARGS, 1..2] of Integer;
CMD_TAIL : String[127];
{ parse_arg -- parse command line arguments TP7 }
procedure PARSE_ARG;
{Split the command line tail into arguments using blanks as separators.
If an argument requires embedded blanks, surround it with quotation
marks (") which will be stripped off retaining the embedded blanks.}
const
DELIMITER = DQUOTE;
type
STR_PTR = ^String;
var
INDEX : Integer;
C : CHARACTER;
CMD_TAIL_LEN : Integer; {length of command tail}
begin
CMD_TAIL := STR_PTR(Ptr(PrefixSeg, $80))^;
NARG := 0;
for INDEX := 1 to MAX_ARGS do
begin
ARGS[INDEX, 1] := 0;
ARGS[INDEX, 2] := 0;
end; { for }
CMD_TAIL_LEN := Length(CMD_TAIL);
if (CMD_TAIL_LEN <> 0) then
begin
INDEX := 1;
repeat
if (Ord(CMD_TAIL[INDEX]) <> BLANK) then
begin
Inc(NARG);
if (Ord(CMD_TAIL[INDEX]) = DELIMITER) then
begin
ARGS[NARG, 1] := INDEX+1;
C := DELIMITER;
end
else
begin
ARGS[NARG, 1] := INDEX;
C := BLANK;
end; { if }
repeat
Inc(INDEX);
until ((Ord(CMD_TAIL[INDEX]) = C) or
(INDEX > CMD_TAIL_LEN));
ARGS[NARG, 2] := INDEX-1;
end; { if }
Inc(INDEX);
until (INDEX > CMD_TAIL_LEN);
end; { if }
end; { procedure }
{------------------------------------------------}
#include "error.p"
#include "message.p"
#include "prims.p"
begin
INITIO;
end.
{!utility.i!}
{$I COMPILER.INC}
#include "header.p"
unit UTILITY;
interface
uses GLOBDEFS;
function ADDSTR(C : CHARACTER;
var OUTSET : STRINGZ;
var J : Integer;
MAXSET : Integer) : Boolean;
function EQUAL(var STR1, STR2 : STRINGZ) : Boolean;
function ESC(var S : STRINGZ;
var I : Integer) : CHARACTER;
function INDEXZ(var S : STRINGZ;
C : CHARACTER) : Integer;
function ISALPHANUM(C : CHARACTER) : Boolean;
function ISDIGIT(C : CHARACTER) : Boolean;
function ISLETTER(C : CHARACTER) : Boolean;
function ISLOWER(C : CHARACTER) : Boolean;
function ISUPPER(C : CHARACTER) : Boolean;
function ITOC(N : Integer;
var S : STRINGZ;
I : Integer) : Integer;
function LENGTHZ(var S : STRINGZ) : Integer;
function MAX(X, Y : Integer) : Integer;
function MIN(X, Y : Integer) : Integer;
procedure SCOPY(var SRC : STRINGZ;
I : Integer;
var DEST : STRINGZ;
J : Integer);
function CTOI(var S : STRINGZ;
var I : Integer) : Integer;
procedure FCOPY(FIN, FOUT : FILEDESC);
function MUSTCREATE(var NAME : STRINGZ;
MODE : Integer) : FILEDESC;
function MUSTOPEN(var NAME : STRINGZ;
MODE : Integer) : FILEDESC;
procedure PUTDEC(N, W : Integer);
implementation
uses PRIMS;
#include "utility.p"
end.
{!charcnt.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "charcnt.p"
begin
CHARCOUNT;
end.
{!linecnt.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "linecnt.p"
begin
LINECOUNT;
end.
{!wordcnt.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "wordcnt.p"
begin
WORDCOUNT;
end.
{!detab.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "detab.p"
begin
DETAB;
end.
{!entab.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "entab.p"
begin
ENTAB;
end.
{!overstrk.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "overstrk.p"
begin
OVERSTRIKE;
end.
{!compress.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "compress.p"
begin
COMPRESS;
end.
{!expand.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "expand.p"
begin
EXPAND;
end.
{!echoz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "echo.p"
begin
ECHO;
end.
{!translit.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "translit.p"
begin
TRANSLIT;
end.
{!compare.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "compare.p"
begin
COMPARE;
end.
{!include.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "includez.p"
begin
INCLUDEZ;
end.
{!concat.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "concatz.p"
begin
CONCATZ;
end.
{!printz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "print.p"
begin
PRINT;
end.
{!makecopy.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "makecopy.p"
begin
MAKECOPY;
end.
{!archive.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "archive.p"
begin
ARCHIVE;
end.
{!sortz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "sort.p"
begin
SORT;
end.
{!unique.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "unique.p"
begin
UNIQUE;
end.
{!kwic.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "kwic.p"
begin
KWIC;
end.
{!unrotate.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "unrotate.p"
begin
UNROTATE;
end.
{!findz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "find.p"
begin
FIND;
end.
{!change.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "change.p"
begin
CHANGE;
end.
{!edit1.i!}
{$I COMPILER.INC}
#include "header.p"
{$define INMEM}
uses GLOBDEFS, PRIMS, UTILITY;
#include "edit1.p"
begin
EDIT;
end.
{!edit2.i!}
{$I COMPILER.INC}
#include "header.p"
{$define INMEM}
uses GLOBDEFS, PRIMS, UTILITY;
#include "edit2.p"
begin
EDIT;
end.
{!formatz.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "format.p"
begin
FORMAT;
end.
{!define.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "define.p"
begin
DEFINE;
end.
{!macro.i!}
{$I COMPILER.INC}
#include "header.p"
uses GLOBDEFS, PRIMS, UTILITY;
#include "macro.p"
begin
MACRO;
end.